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