Please Help! VBA loop and paste

[Excelnoobisme]

Hi, i have 2 workbooks, 'Database.xlsm' and 'Daily.xlsx'.

Column A in 'Database.xlsm' is the Date(1st march,2nd march......) with other info pertaining to that date on Column B-F.( i have on average 3000 rows of data everyday)

Now every month i need to transfer the amount in 'Database.xlsm' to 'Daily.xlsx' according to their date, in a way that amount for 1st march will on the 1st tab in 'Daily.xlsx' and 2nd march amount will be in the 2nd tab...

In short, i need a marco to loop through column A, search for all 1st march data and copy to 'Daily.xlsx then continue to search for 2nd march data and copy to 2nd tab in 'daily.xlsx.

Thanks

 

[jim may]

This works for me (Note Chg required by you In RED)

Sub Foo()
    Dim MyGrp As Range
    Dim Rng As Range
    Dim NumInRng As Integer
    Dim DestWb As Workbook
    Application.ScreenUpdating = False
    wsnum = 0
    Set Rng = Range("A2:F2")
    Range("A2").Select
    Lr = Range("A" & Rows.Count).End(xlUp).Row
    If Lr > 2 Then
    Set DestWb = Workbooks.Add()
    DestWb.SaveAs Filename:=[COLOR="Red"]"C:\Users\James\Documents\ExcelChest\MyDestWb.xlsx"[/COLOR]
    End If
    ThisWorkbook.Activate
    Do Until ActiveCell.Row = Lr + 1
    If ActiveCell.Offset(1).Value = ActiveCell Then
    NumInRng = NumInRng + 1
    ActiveCell.Offset(1).Select
    Else
    wsnum = wsnum + 1
    If Workbooks([COLOR="red"]"MyDestWb.xlsx[/COLOR]").Worksheets.Count < wsnum Then
    With Workbooks("[COLOR="red"]MyDestWb.xlsx[/COLOR]")
        .Worksheets.Add After:=Worksheets(.Worksheets.Count)
    End With
    End If
    Set MyGrp = Rng.Resize(NumInRng + 1, 6)
    ActiveCell.Offset(1).Select
    Set Rng = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 6))
    NumInRng = 0
    Workbooks("[COLOR="red"]MyDestWb.xlsx[/COLOR]").Sheets(wsnum).Range("A1:F1").Value = ThisWorkbook.Sheets("Sheet1").Range("A1:F1").Value
    Dlr = DestWb.Sheets(wsnum).Range("A" & Rows.Count).End(xlUp).Row + 1
    MyGrp.Copy Destination:=Workbooks("[COLOR="red"]MyDestWb.xlsx[/COLOR]").Sheets(wsnum).Range("A" & Dlr)
    With Workbooks("[COLOR="red"]MyDestWb.xlsx[/COLOR]")
        .Sheets(wsnum).Columns("A:A").EntireColumn.AutoFit
    End With
    Application.CutCopyMode = False
    End If
    Loop
    Workbooks("[COLOR="red"]MyDestWb.xlsx[/COLOR]").Activate
    Worksheets("Sheet1").Select
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub