Question

I have 3 issues with the following piece of code:

Intention of code: I have a table of data, 4 columns (F,G, H and I) wide and X rows long (X is typically between 5 and 400). I have a list of dates in column M, typically no more than 8 dates. Column H of table, contains dates as well. I want to find the dates that are in both columns (H and M) and whenever they appear, go to the same row in column I and set its value to zero, and the one after it (so if a match was in H100, then I100 and I101 would be zeroed).

issues with code: edited 1) as per feedback.

1) I have, using an if formula (=if(H100=M12,1,0), verified that there is one match, as how the spreadsheet sees it. The macro does not find this match, despite confirmation from the if formula. Cells I100 and I101 have nonzero values, when they should be zeroed.

2) the code runs, but takes about 3 minutes to go through 3 sheets of 180 rows of data. What can be done to make it run faster and more efficiently? It could have up to 30 sheets of data, and 400 rows (extreme example but possible, in this instance im happy to let it run a bit).

3) Assuming my data table before the macro is run, is 100 rows long, starting in row 12, after the macro, column I has nonzero values for 111 rows, and zeroes for the next 389. Is there a way I can prevent it from filling down zeroes, and leaving it blank?

I am using a correlate function afterwards on column I and there huge agreement of 0’s with 0’s is distorting this significantly. Thanks in advance,

Sub DeleteCells()


Dim ws As Worksheet
Dim cell As Range, search_cell As Range
Dim i As Long
Dim h As Long


Application.ScreenUpdating = False




For Each ws In ThisWorkbook.Worksheets
    If Not ws.Name = "Cover" Then
        For Each cell In ws.Range("H12:H500")



            On Error Resume Next
            h = ws.Range("G" & Rows.Count).End(xlUp).Row
             i = ws.Range("L" & Rows.Count).End(xlUp).Row
            Set search_cell = ws.Range("M12:M" & h).Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)
            On Error GoTo 0
            If Not search_cell Is Nothing Then
                ws.Range("I" & cell.Row).Value = 0
                ws.Range("I" & cell.Row + 1).Value = 0
                Set search_cell = Nothing
            End If
        Next cell
    End If
Next ws





Application.ScreenUpdating = True




Set ws = Nothing: Set cell = Nothing: Set search_cell = Nothing




End Sub

Answer 1

EDIT: TESTED CODE, will work for 0, 1 row of data in H/M column starting from row 12?

EDIT: Updated the cell to handle case with 1 line of data, untested 😐

I will give my solution first, this one should be much faster because it read the cells into memory first

Please comment if it doesn’t work or you have further question

Sub DeleteCells()


Dim ws As Worksheet
Dim i As Long
Dim h As Long
Dim MColumn As Variant  ' for convinence
Dim HColumn As Variant
Dim IColumn As Variant
Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Worksheets
    If Not ws.Name = "Cover" Then  'matching the target sheet
    ' matching the rows where column M's date matches column H's date
        'starting row num is 12
        With ws ' for simplifying the code
            h = .Range("H" & .Rows.count).End(xlUp).Row
            If h = 12 Then ' CASE for 1 row only
                If Range("H12").Value = Range("M12").Value Then
                    Range("I12:I13").Value = ""
                End If

            ElseIf h < 12 Then
                ' do nothing

            Else
                ReDim HColumn(1 To h - 11, 1 To 1)
                ReDim MColumn(1 To h - 11, 1 To 1)
                ReDim IColumn(1 To h - 10, 1 To 1)
                ' copying the data from worksheet into 2D arrays
                HColumn = .Range("H12:H" & h).Value
                MColumn = .Range("M12:M" & h).Value
                IColumn = .Range("I12:I" & h + 1).Value

                For i = LBound(HColumn, 1) To UBound(HColumn, 1)
                    If Not IsEmpty(HColumn(i, 1)) And Not IsEmpty(MColumn(i, 1)) Then
                        If HColumn(i, 1) = MColumn(i, 1) Then
                            IColumn(i, 1) = ""
                            IColumn(i + 1, 1) = ""
                        End If
                    End If
                Next i
                'assigning back to worksheet cells
                .Range("H12:H" & h).Value = HColumn
                .Range("M12:M" & h).Value = MColumn
                .Range("I12:I" & h + 1).Value = IColumn
            End If

        End With
    End If
Next ws
Application.ScreenUpdating = True
End Sub