Move rows from One sheet to another based on the year

[BernieL]

I would like to thank everyone for all the great information on this site. For my first post I would like to ask for assistance in regards to moving a row of Data based on a year. I have tried to do it based on the information on this site but have not had any success.

Attached is a copy of the workbook with fake data. What I want to do is copy all rows from the worksheet DATA based on column G (Date) and copy it to a new sheet based on the date (all 2003 on the 2003 sheet and all 2004 on 2004 sheet.....). I have already created the new sheets including headers minus data. I would like to have all the data moved except the last to Columns AW & AX. I have two hidden sheets in this workbook. Would it be possible to have it auto-populate future entries from the "DATA" worksheet to autofill onto the new sheets?

I would like to thank you for your assistance.

Just noticed that I titled the Thread with Move but what I am asking for is copy. I cannot change the Thread title.

[Charles]

Hi,
Here's what I came up with.
Paste it to a module.

Sub test()
Dim intslash
Dim MyCell As Range
Dim MyYear As String
Dim Lrow As Long, WSLrow As Long
Dim MySheet As Worksheet
Lrow = Sheets("Data").Range("G65536").End(xlUp).Row

For Each MyCell In Range("G3:G" & Lrow)
    intslash = InStrRev(Range("G3"), "/")
    MyYear = Right(Range("G3"), intslash - 2)
    ''' now loop thry worksheets and copy info to them
    For Each MySheet In Worksheets
     If Right(MySheet.Name, 4) = MyYear Then
     '' get next empty cell in worksheet
        WSLrow = Sheets(MySheet.Name).Range("O65536").End(xlUp).Row + 1
        Range("A" & MyCell.Row & ":AV" & MyCell.Row).Copy Destination:=Sheets(MySheet.Name).Cells(WSLrow, 1)
     End If
Next MySheet
Next
End Sub

[Charles]

Revised code fond error.

Sub test()
Application.ScreenUpdating = False
Dim MyCell As Range
Dim MyYear As String
Dim Lrow As Long, WSLrow As Long
Dim MySheet As Worksheet
Lrow = Sheets("Data").Range("G65536").End(xlUp).Row

For Each MyCell In Range("G3:G" & Lrow)
    MyYear = Right(Range("G" & MyCell.Row), 4)
    ''' now loop thry worksheets and copy info to them
    For Each MySheet In Worksheets
     If Right(MySheet.Name, 4) = MyYear Then
     '' get next empty cell in worksheet
        WSLrow = Sheets(MySheet.Name).Range("O65536").End(xlUp).Row + 1
        Range("A" & MyCell.Row & ":AV" & MyCell.Row).Copy Destination:=Sheets(MySheet.Name).Cells(WSLrow, 1)
        
        Exit For
     End If
Next MySheet
Next
End Sub

Did not need the Instr.
And had to reset range.

[BernieL]

Charles thanks for the Help much appreciated. It only copied the last enty into each sheet based on the year. To explain better ther are 854 entries the last row (854) year is 2006 so this one appears on the Ritux 2006 sheet and the last 2005 is on the 2005 sheet and so on.

[Charles]

Hi,

Error on my part. The way you have each sheet formated I made the assumption that Column "O" would have data posted, so I used that column to get the last empty row.
This should now post all data to its own row.

Sub test()
Application.ScreenUpdating = False
Dim MyCell As Range
Dim MyYear As String
Dim Lrow As Long, WSLrow As Long
Dim MySheet As Worksheet
Lrow = Sheets("Data").Range("G65536").End(xlUp).Row

For Each MyCell In Range("G3:G" & Lrow)
    MyYear = Right(Range("G" & MyCell.Row), 4)
    ''' now loop thry worksheets and copy info to them
    For Each MySheet In Worksheets
     If Right(MySheet.Name, 4) = MyYear Then
     '' get next empty cell in worksheet
        WSLrow = Sheets(MySheet.Name).Range("A65536").End(xlUp).Row + 1
        If WSLrow <= "2" Then
            WSLrow = "3"
        End If
        Range("A" & MyCell.Row & ":AV" & MyCell.Row).Copy Destination:=Sheets(MySheet.Name).Cells(WSLrow, 1)
        
        Exit For
     End If
Next MySheet
Next
End Sub

[BernieL]

Charles,

Thank you very much this did the trick all things worked out!!!!

[Charles]

Thanks for the update.