Code to delete 2nd percent in Excel (Excel xp)

Topic

New Reply

I have a workbook with multiple worksheets. I need to go through each worksheet and delete the 2nd percentage if there are 2 in a row. So i need to delete B4:U4 and move A4 up to A3. I put some of them in red.

I made a “New” worksheet to show how i would like the sheets to come out after the 2nd percent is deleted.

How can i make a macro to do this as i have 400 worksheets to go through.

Thank you for the help.

Reply | Quote

Replies

Put the following code into a standard module:

Sub Delete2ndPercentages(oSheet As Worksheet)
Dim lngRow As Long
For lngRow = oSheet.Cells(65536, 2).End(xlUp).Row To 2 Step -1
If IsPercent(oSheet.Cells(lngRow, 2)) Then
If IsPercent(oSheet.Cells(lngRow – 1, 2)) Then
oSheet.Cells(lngRow – 1, 1) = oSheet.Cells(lngRow, 1)
oSheet.Rows(lngRow).Delete
End If
End If
Next lngRow
End Sub

Function IsPercent(oCell As Range) As Boolean
IsPercent = InStr(oCell.NumberFormat, “%”) > 0
End Function

Call the procedure like this:

Delete2ndPercentages Worksheets(“Original”)

Notes:
– Your use of “2 in a row” is confusing if you are talking about a spreadsheet
– The placement of “Total Answering” in the ‘New’ sheet is inconsistent.

Reply | Quote

Hi Hans,

Thank you very much. That works great! Now i realize i want to delete the cells that are NOT in COL A, that have text. How do i write a function that is like

Function IsText(oCell As Range) As Boolean
IsText = code to see if the cell has text in it
End Function

so i can delete those rows as well. Thanks

Reply | Quote

Excel has a worksheet function ISTEXT, so you can use that:

IsText = Application.WorksheetFunction.IsText(oCell)

Reply | Quote

Excel has a worksheet function ISTEXT, so you can use that:

IsText = Application.WorksheetFunction.IsText(oCell)

Reply | Quote

Hi Hans,

Thank you very much. That works great! Now i realize i want to delete the cells that are NOT in COL A, that have text. How do i write a function that is like

Function IsText(oCell As Range) As Boolean
IsText = code to see if the cell has text in it
End Function

so i can delete those rows as well. Thanks

Reply | Quote

Put the following code into a standard module:

Sub Delete2ndPercentages(oSheet As Worksheet)
Dim lngRow As Long
For lngRow = oSheet.Cells(65536, 2).End(xlUp).Row To 2 Step -1
If IsPercent(oSheet.Cells(lngRow, 2)) Then
If IsPercent(oSheet.Cells(lngRow – 1, 2)) Then
oSheet.Cells(lngRow – 1, 1) = oSheet.Cells(lngRow, 1)
oSheet.Rows(lngRow).Delete
End If
End If
Next lngRow
End Sub

Function IsPercent(oCell As Range) As Boolean
IsPercent = InStr(oCell.NumberFormat, “%”) > 0
End Function

Call the procedure like this:

Delete2ndPercentages Worksheets(“Original”)

Notes:
– Your use of “2 in a row” is confusing if you are talking about a spreadsheet
– The placement of “Total Answering” in the ‘New’ sheet is inconsistent.

Reply | Quote

Does this do what you want:

Public Sub DelRows()
Dim lLastRow As Long, I As Long
Dim oCell As Range, oWks As Worksheet, oMergedRange As Range
    Set oWks = Worksheets("Original")
    Set oCell = oWks.Range("B1")
    lLastRow = oWks.Range("B65536").End(xlUp).Row - 1
    For I = lLastRow To 1 Step (-1)
        If Right(oCell.Offset(I, 0).Text, 1) = "%" And Right(oCell.Offset(I - 1, 0).Text, 1) = "%" Then
            Set oMergedRange = oCell.Offset(I, -1).MergeArea
            oMergedRange.UnMerge
            oCell.Offset(I, 0).EntireRow.Delete
            oMergedRange.Merge
        End If
    Next I
End Sub

Reply | Quote

Does this do what you want:

Public Sub DelRows()
Dim lLastRow As Long, I As Long
Dim oCell As Range, oWks As Worksheet, oMergedRange As Range
    Set oWks = Worksheets("Original")
    Set oCell = oWks.Range("B1")
    lLastRow = oWks.Range("B65536").End(xlUp).Row - 1
    For I = lLastRow To 1 Step (-1)
        If Right(oCell.Offset(I, 0).Text, 1) = "%" And Right(oCell.Offset(I - 1, 0).Text, 1) = "%" Then
            Set oMergedRange = oCell.Offset(I, -1).MergeArea
            oMergedRange.UnMerge
            oCell.Offset(I, 0).EntireRow.Delete
            oMergedRange.Merge
        End If
    Next I
End Sub

Reply | Quote