Copy Data Based on Date Range

Hi Everybody,

I have been struggling to figure this out, I am hoping you guys can help me figure this out.
I have attached a spreadsheet. I need to copy data from the influent tab and paste it under the proper date in the summary tab.

I have recorded a macro doing this (see below), only now I need it to automatically go thorugh all rows in the influent tab and automatically find the correct date in the summary tab to paste the row.


Thanks for your help.

Sub Copy()
'
' Copy Macro
'

'
    Rows("2:2").Select
    Selection.Copy
    Sheets("Summary").Select
    ActiveWindow.SmallScroll Down:=81
    Rows("103:103").Select
    ActiveSheet.Paste
    Range("E111").Select
End Sub

Book1.xlsx

Hello tranjo,

Welcome to the Forum!

The following macro has been added to the attached workbook. There is a button on the "Influent" sheet to run the macro.

Sub CopyDateByDate()

    Dim Cell        As Range
    Dim cols        As Long
    Dim Data        As Variant
    Dim DstRng      As Range
    Dim LastCell    As Range
    Dim Search      As Range
    Dim SrcRng      As Range
    
        Set SrcRng = Worksheets("Influent").Range("A2")
        Set LastCell = SrcRng.Parent.Cells(Rows.Count, "A").End(xlUp)
        Set SrcRng = SrcRng.Parent.Range(SrcRng, LastCell)
        
        If LastCell.Row < SrcRng.Row Then
            MsgBox "There is No Data to Search.", vbOKOnly + vbExclamation
            Exit Sub
        End If
        
        Set DstRng = Worksheets("Summary").Range("A2")
        Set LastCell = DstRng.Parent.Cells(Rows.Count, "A").End(xlUp)
        Set DstRng = IIf(LastCell.Row < DstRng.Row, DstRng, DstRng.Parent.Range(DstRng, LastCell))
        
            col = SrcRng.Cells(1, Columns.Count).End(xlToRight).Column
            ReDim Data(1 To cols)
            
            Application.ScreenUpdating = False
            
            With Application.FindFormat
                .Clear
                .NumberFormat = SrcRng.Cells(1, 1).NumberFormat
            End With
            
            For Each Cell In SrcRng
                Set Search = DstRng.Find(Cell, , xlFormulas, xlWhole, xlByRows, xlNext, False, False, True)
                If Not Search Is Nothing Then
                    Data = Cell.Resize(1, cols).Value
                    Search.Resize(1, cols) = Data
                End If
            Next Cell
            
            Application.ScreenUpdating = True
            
End Sub

Hello tranjo,

Sorry, my typing is not very good. I left of the "s" on "cols". The line should be...

    cols = SrcRng.Cells(1, Columns.Count).End(xlToRight).Column