I am trying to create a macro to check the whole excel sheet and find if there are any dates 2 days after or before from today's date

Question

Private Sub CommandButton5_Click()

Dim ws As Worksheet, lRow As Integer

For Each ws In Worksheets
    If ws.Name <> "Sheet1" Then
        lRow = ws.Range("A" & Rows.Count).End(xlUp).Row
        For Each cell In Range("A2:A" & lRow)
            If cell.Value >= Date - 2 And cell.Value <= Date + 2 Then
                cell.EntireRow.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        Next cell
    End If
Next ws
End Sub

This code is searching in just 1st column, I want it to search in the whole sheet. How do I do that ? Any suggestions ?

Answer 1

To check the whole Excel sheet is really slow if you have a lot of data.

But you can access directly to cells that contains a value, ignoring blanks and checking if the value fullfills your requirements.

For Each rng In ws.Cells.SpecialCells(xlCellTypeConstants, 1) 'change xlCellTypeConstants to xlCellTypeFormulas if your dates are formulas
    If rng.Value >= Date And rng.Value <= (Date + 2) Then
        'do what you want

    End If
Next rng

This code will check all non blank cells in the sheet. Also, notice that dates are numeric values, so if any cell contais a number, it will be treated as date even if the number is typed something like 12345.

Unless you know for sure that the only numbers in cells are dates, you should add an extra condition in your IF...Thento check if the number is really a date (maybe checking the format of the cell, or whatever).

This code should speed up the process heavily. Your actual loop check all cells, so it's time consuming.

Hope you can adapt this to your needs.

XlCellType enumeration (Excel)

Answer 2

I suggest you read the usedRange of your sheet(s) into an array (= 1 very fast statement) and then loop over the array. Pls. check my comments re copy target (sheet2) and avoiding copying the same line multiple times.

Private Sub CommandButton5_Click()

Dim ws As Worksheet
Dim lastCell As Range
Dim i As Long, j As Long, unusedRow As Long
Dim vals As Variant
Dim targetSheet As Worksheet

Set targetSheet = Sheets("Sheet2")                        'Do you really want to copy to Sheet2? Its one of the sheets you re searching........

For Each ws In Worksheets
    If ws.Name <> "Sheet1" Then
        Set lastCell = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
        vals = Range(ws.Cells(1, 1), lastCell).Value
        For i = 2 To UBound(vals, 1)                                'Excludes the first row of any sheet - as in your code
            For j = 1 To UBound(vals, 2)
                If IsDate(vals(i, j)) Then
                    If vals(i, j) >= Date - 2 And vals(i, j) <= Date + 2 Then
                        unusedRow = targetSheet.Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
                        ws.Rows(i).Copy targetSheet.Cells(unusedRow, 1)
                        Exit For                        'Assume you dont want to copy the same line more than once - so quit the inner loop after the first find
                    End If
                End If
            Next j
        Next i
    End If
Next ws

End Sub

Answer 3

Like one of the other users suggested, you want to verify that you are comparing similar data types. In the example below, I've added a check to verify that the cell you are comparing is, in fact, a date. If so, then excel can handle subtracting them. Additionally, the abs(value) will handle your "before or after" 2 day time check.

As other people have said, there are other ways to handle this but this is how I'd approach checking every cell on the sheet using the method you started with.

Dim ws, copySheet As Worksheet
Dim cel, searchRange As Range

Set ws = ActiveWorkbook.Sheets("SheetYouWantToCheck")
Set searchRange = ws.UsedRange
Set copySheet = ActiveWorkbook.Sheets("SheetYouWantToCopyTo")

For Each cel In searchRange.Cells
    If IsDate(cel.Value) = True Then
         If Abs(cel.Value - Date) <= 2 Then
              copySheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = cel.Value
         End If
    End If
Next

Answer 4

To iterate over all of the cells that contain a date, first we can use the special cell type xCellTypeLastCell to find the last cell populated with data.

Then, we loop over all the cells from the starting position of A1 (i.e. 1,1) until the last cell we found earlier.

If we find a cell with the criteria defined by the OP, we copy it to another worksheet.

Private Sub CommandButton5_Click()

Dim ws As Worksheet, xlastRow As Integer, xlastCol As Integer

For Each ws In Worksheets
    If ws.Name <> "Sheet1" Then
        xlastRow = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
        xlastCol = ws.Cells.SpecialCells(xlCellTypeLastCell).Column

        Dim cell As Range
        For Each cell In Range(ws.Cells(1, 1), ws.Cells(xlastRow, xlastCol))
            If cell.Value >= Date - 2 And cell.Value <= Date + 2 Then

                Dim destSheet As Worksheet
                Set destSheet = Worksheets("Sheet2")
                cell.Copy destSheet.Range(cell.Address)

            End If
        Next cell
    End If
Next ws
End Sub

Answer 5

There are very good suggestions here, in particular for general cases where complex calculations or iterations are to be made over large sets of data:

• Passing your data into an array instead of looping through each cell: with Office, what is time-expensive are call instantiations, and this reduces the calls from VBA to Excel to 1 large call rather than plenty of small calls.
• Relying on a filter such as Cells.SpecialCells(xlCellTypeConstants, 1) also reduces the amount of cells to be processed.

But I believe that for your very specific case, you could do much simpler (and arguably efficient), by relying on .Find(), which will return the set of cells matching a given pattern (see documentation).

Simply search for cells whose values are equal to the 5 possibles dates: Today -2 through to Today +2 :

Private Sub CommandButton5_Click()

    Dim FoundCell as Range
    Dim ws As Worksheet

    For Each ws In Worksheets

        If ws.Name <> "Sheet1" Then

            For i = -2 to 2 

                FoundCell = ws.UsedRange.Find(Date(Now) + i,lookin:=xlValues)
                If Not FoundCell Is Nothing then
                    Something(FoundCell) 'Do Something on the first cell
                    FoundCell = .FindNext(FoundCell) ' Go to the next cell found
                End If

            Next i

        End If

    Next ws   

End Sub