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

elpepe1970

New Member
Joined
Oct 7, 2024
Messages
7
Office Version
  1. 2016
  2. 2013
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.
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
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
 
Upvote 0
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.
 
Upvote 0
I just saw your message, sorry for the late reply. I have updated it as you mentioned.

VBA Code:
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
 
Upvote 1
Solution
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.
 
Upvote 0

Forum statistics

Threads
1,223,932
Messages
6,175,468
Members
452,646
Latest member
tudou

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top