VBA code to copy data to seperate sheet on successive rows of same sheet

[traub86]

I am new at this but I feel that I have exhausted mysearch resources for my specific issue. I currently have a workbook with 5sheets. Sheets 1-4 have the exact same template but data within them maychange. Sheet 5 records specific data within each sheet with the click of amacro button into an organized fashion in rows. The VBA code I have works perfectlyfor the initial data, however I will be systematically moving from sheet 1-4and then over again and need previous data to remain unchanged (I.e. Sheet 1 willbe recorded on line 1, 5, 9, sheet 2 recorded on line 2, 6, 10, etc.). How do Iaccomplish this with the click of the same button? Here is the code I currentlyhave:

Sub CopyDataToDZLOG()
Dim NewRow: NewRow = GetNextEmptyRowOnDZLOG
Worksheets("DZ LOG").Cells(NewRow, 2).Value = Worksheets("CHALK 1").Range("C18").Value
Worksheets("DZ LOG").Cells(NewRow, 5).Value = Worksheets("CHALK 1").Range("E7").Value
Worksheets("DZ LOG").Cells(NewRow, 6).Value = Worksheets("CHALK 1").Range("E4").Value

End Sub
Function GetNextEmptyRowOnDZLOG() As Integer
Dim RowCount: RowCount = 6
Do
RowCount = RowCount + 1
Loop Until IsEmpty(Worksheets("DZ LOG").Cells(RowCount, 20).Value)
GetNextEmptyRowOnDZLOG = RowCount
End Function


Please help. Thanks.

 

[D3allamerican07]

Traub86,

Try: Loops through sheets 1-4, pastes on successive rows. Let me know if you have any issues.

Sub Test()

For i = 1 To 4
    Sheets(i).Activate
    LR = Range("A" & Rows.Count).End(xlUp).Row
    codeC = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
    codeLC = Replace(Cells(1, codeC).Address(False, False), "1", "")
    
        If i = 1 Then
            j = 1
        ElseIf i = 2 Then
            j = 2
        ElseIf i = 3 Then
            j = 3
        Else
            j = 4
        End If
        
    For Each cell In Sheets(i).Range("A2:A" & LR)
        Sheets(i).Range("A" & cell.Row & ":" & codeLC & cell.Row).Copy Destination:=Sheets(5).Range("A" & j)
        j = j + 4
    Next cell
Next i

End Sub

Bill

 

[traub86]

Thanks for the quick reply. So I have 4 different codes with respect to each sheet (i.e. Chalk 1, Chalk 2, Chalk 3 and Chalk 4). Do I need to have this one code in 4 different locations or do I need to designate per sheet?

 

[D3allamerican07]

Traub86,

The updated code will work for all sheets. It only needs to be added to one module and run.

Sub Test()

For i = 1 To 4
    Sheets("Chalk " & i).Activate
    LR = Range("A" & Rows.Count).End(xlUp).Row
    codeC = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
    codeLC = Replace(Cells(1, codeC).Address(False, False), "1", "")
    
        If i = 1 Then
            j = 1
        ElseIf i = 2 Then
            j = 2
        ElseIf i = 3 Then
            j = 3
        Else
            j = 4
        End If
        
    For Each cell In Sheets("Chalk " & i).Range("A2:A" & LR)
        Sheets("Chalk " & i).Range("A" & cell.Row & ":" & codeLC & cell.Row).Copy Destination:=Sheets(5).Range("A" & j)
        j = j + 4
    Next cell
Next i

End Sub

You can change the 5 to what ever name your output sheet is name as well. Make sure it looks like this in between the parenthesis ("OUTPUT").

Sheets("Chalk " & i).Range("A" & cell.Row & ":" & codeLC  & cell.Row).Copy Destination:=Sheets(5).Range("A" & j)

 

[traub86]

I put the code in and an error box popped up saying couldn't paste to merged cell, but the cell I have it going to is not merged. Is there a way I can just add something to the code I had to populate in the next available row?