Loop to compile data to last sheet not working.

[CreativeUsername]

the following is not working. I'm not seeing why. also I need it to print In the Cell "A" for each line transferred
todays date (and it shouldn't update the next day) Cell "B" for each row transferred should be the Sheet name the data came from.

The following was working perfectly before putting in the loop. It doesn't have the date and sheet name part yet. Any help is appreciated.

Sub ArchiveTrans()
Dim ws As Worksheet
Dim LastRow As Long
Dim SourceWB As Workbook

Application.ScreenUpdating = False

'Select source location and range
For Each ws In SourceWB.Worksheets
If ws.Name <> "Change Control" And ws.Name <> "Archive" Then
ActiveSheet.Select
Set destRng = Sheets("Archive").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)

'Copy selected range to last row
LastRow = Range("B" & Rows.Count).End(xlUp).Row
Range("A:AK" & LastRow).Copy Destination:=destRng

End If
Next ws
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub

 

[Veritan]

This code may be what you're looking for. Please bear in mind that I'm guessing as to what your situation is, and I don't know if everything will work the way you want it to. Try testing this out in a copy of your worksheet and seeing if it works for you. I left some notes in the code regarding some of the changes I made.

Sub ArchiveTrans()
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim SourceWB As Workbook
    [COLOR=#008000]'Remember to declare ALL of your variables here. It saves headaches later.[/COLOR]
    Dim destRng As Range
    
    Application.ScreenUpdating = False
    
    [COLOR=#008000]'This line is unnecessary if you are only working with 1 workbook. _
    If you are using multiple workbooks, this needs to be set to the actual Source workbook.[/COLOR]
    Set SourceWB = ActiveWorkbook
    
    For Each ws In SourceWB.Worksheets
        [COLOR=#008000]'This is a little better location for this line. _
        I changed the "C" to a 3, but you can probably get away with the "C" if you want.[/COLOR]
        Set destRng = Sheets("Archive").Cells(Rows.Count, 3).End(xlUp).Offset(1)
        If ws.Name <> "Change Control" And ws.Name <> "Archive" Then
            [COLOR=#008000]'ActiveSheet.Select does nothing, since you've already selected the sheet. _
            It's essentially dead code, and should be removed.[/COLOR]
            
            [COLOR=#008000]'These 2 lines will put the date and sheet name in Columns A and B.[/COLOR]
            destRng.Offset(, -2) = Date
            destRng.Offset(, -1) = ws.Name
            [COLOR=#008000]'Range has been changed to ws.Cells, which references the current sheet the loop is looking at.[/COLOR]
            LastRow = ws.Cells(Rows.Count, 2).End(xlUp).Row
            [COLOR=#008000]'Range("A:AK" & LastRow) may work, but it seems prone to failure, in my humble opinion. _
            This version of selecting the last row will make sure that you get everything in the row. _
            It also avoids a lot of issues that can come with Copy/Pasting.[/COLOR]
            Range(ws.Cells(LastRow, 1), ws.Cells(LastRow, Columns.Count).End(xlToLeft)).Copy Destination:=destRng
        End If
    Next ws
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

 

[CreativeUsername]

This works on a sheet by sheet basis with out a loop. I just need it to loop through the whole workbook and copy the block of data to an "archive" sheet give me the WS name and the Date. THEN there is another sub it runs through that uses SourceWB as "ThisWorkbook".The above works but only copies one line. I need all lines as below. I feel like this should be a lot easier to put THIS code into a loop.

Sub CopyRows()

Dim LastRow As Long

Application.ScreenUpdating = False

'Select source location and range

Sheets("Data1").Select
Set destRng = Sheets("Data2").Cells(Rows.Count, "A").END(xlUp).Offset(1, 0)

'Copy selected range to last row

LastRow = Range("A" & Rows.Count).END(xlUp).Row
Range("A1:D" & LastRow).Copy Destination:=destRng

'Select destination and range and paste

End With
End Sub