Is there a VBA that searches all sheets in any workbook, for today date, and copy the entire row

[elpepe1970]

I receive a daily report incluiding daily results with several sheets, but need to extract in a new workbook the data corresponding to each day. Is there any VBA that locate today's date in each and every sheet and copy the row whit that info to a new work book, something to make a summary. The dates are in column A and there is a info in columns B to O
Thanks in advance for your help.

 

[pitchoute]

Below is a VBA script that searches all sheets in your current workbook for today's date in Column A. When it finds a match, it copies the entire row (from Column A to Column O) and pastes it into a new workbook to create a summary of today's data.

Sub ExtractTodayData()
Dim ws As Worksheet
Dim newWb As Workbook
Dim summaryWs As Worksheet
Dim lastRow As Long
Dim summaryRow As Long
Dim cell As Range
Dim todayDate As Date
Dim searchRange As Range
Dim found As Range
Dim firstAddress As String
Dim columnStart As String
Dim columnEnd As String

' Define the columns to copy
columnStart = "A"
columnEnd = "O"

' Get today's date
todayDate = Date

' Create a new workbook for the summary
Set newWb = Workbooks.Add
Set summaryWs = newWb.Sheets(1)
summaryWs.Name = "Today's Summary"

' Initialize summary row
summaryRow = 1

' Add headers to the summary sheet (assuming headers are in the first row of each sheet)
For Each ws In ThisWorkbook.Worksheets
' Copy headers only once
If summaryRow = 1 Then
ws.Range(columnStart & "1:" & columnEnd & "1").Copy Destination:=summaryWs.Range(columnStart & summaryRow)
summaryRow = summaryRow + 1
End If
Next ws

' Loop through each worksheet in the current workbook
For Each ws In ThisWorkbook.Worksheets
' Skip the summary sheet if it's in the same workbook
' (Optional: Comment out if summary is always in a new workbook)
' If ws.Name = "Today's Summary" Then GoTo NextSheet

' Find the last used row in Column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' Define the range to search
Set searchRange = ws.Range("A2:A" & lastRow) ' Assuming headers are in row 1

' Initialize the Find method
Set found = searchRange.Find(What:=todayDate, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

If Not found Is Nothing Then
firstAddress = found.Address
Do
' Copy the entire row from Column A to O
ws.Range(columnStart & found.Row & ":" & columnEnd & found.Row).Copy Destination:=summaryWs.Range(columnStart & summaryRow)
summaryRow = summaryRow + 1

' Find the next occurrence
Set found = searchRange.FindNext(found)
Loop While Not found Is Nothing And found.Address <> firstAddress
End If

NextSheet:
Next ws

' Autofit columns in the summary sheet
summaryWs.Columns(columnStart & ":" & columnEnd).AutoFit

' Notify the user
MsgBox "Today's data has been extracted to a new workbook.", vbInformation, "Process Completed"
End Sub

 

[elpepe1970]

Wow, thanks for the quick response, works fine, one more thing, is there a way to paste as only values, because I´ve found that some of the cells contain math operations or links to other cells on the worksheet. I mean, adding, something like PasteSpecial xlPasteValues , but don'n know where to put it.
Sorry for bother with my pleas.

 

[pitchoute]

I just saw your message, sorry for the late reply. I have updated it as you mentioned.

Sub ExtractTodayData()
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim summaryWs As Worksheet
    Dim lastRow As Long
    Dim summaryRow As Long
    Dim cell As Range
    Dim todayDate As Date
    Dim searchRange As Range
    Dim found As Range
    Dim firstAddress As String
    Dim columnStart As String
    Dim columnEnd As String

    ' Define the columns to copy
    columnStart = "A"
    columnEnd = "O"

    ' Get today's date
    todayDate = Date

    ' Create a new workbook for the summary
    Set newWb = Workbooks.Add
    Set summaryWs = newWb.Sheets(1)
    summaryWs.Name = "Today's Summary"

    ' Initialize summary row
    summaryRow = 1

    ' Add headers to the summary sheet (assuming headers are in the first row of each sheet)
    For Each ws In ThisWorkbook.Worksheets
        ' Copy headers only once
        If summaryRow = 1 Then
            ws.Range(columnStart & "1:" & columnEnd & "1").Copy Destination:=summaryWs.Range(columnStart & summaryRow)
            summaryRow = summaryRow + 1
        End If
    Next ws

    ' Loop through each worksheet in the current workbook
    For Each ws In ThisWorkbook.Worksheets
        ' Skip the summary sheet if it's in the same workbook
        ' (Optional: Comment out if summary is always in a new workbook)
        ' If ws.Name = "Today's Summary" Then GoTo NextSheet

        ' Find the last used row in Column A
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

        ' Define the range to search
        Set searchRange = ws.Range("A2:A" & lastRow) ' Assuming headers are in row 1

        ' Initialize the Find method
        Set found = searchRange.Find(What:=todayDate, LookIn:=xlValues, LookAt:=xlWhole, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

        If Not found Is Nothing Then
            firstAddress = found.Address
            Do
                ' Copy the values directly without formulas
                summaryWs.Range(columnStart & summaryRow & ":" & columnEnd & summaryRow).Value = _
                    ws.Range(columnStart & found.Row & ":" & columnEnd & found.Row).Value
                summaryRow = summaryRow + 1

                ' Find the next occurrence
                Set found = searchRange.FindNext(found)
            Loop While Not found Is Nothing And found.Address <> firstAddress
        End If

    NextSheet:
    Next ws

    ' Autofit columns in the summary sheet
    summaryWs.Columns(columnStart & ":" & columnEnd).AutoFit

    ' Notify the user
    MsgBox "Today's data has been extracted to a new workbook.", vbInformation, "Process Completed"
End Sub

 

[elpepe1970]

There is not need to apologize. this wasn't your job, your doing it as a favor, and it works fantastic, thak yo so much. You are a genius and you are very generous in sharing your knowledge. Again thank you.

 

[pitchoute]

I'm glad it was useful to you. Good luck with your work!