Copy, paste, print + repeat

[TomeK712]

Hi All,

I guess there were a thousand of threads like mine, but I couldn't find the specific case to my issue.

I've got Workbook with 2 Sheets: Source (with data) and Template (with tables and information to print).
I've recorded the first macro with copying data 4 times from one cell Source to another in Template, then print.

And now I'm trying to find the way to do this same but from next cell in Source into this same in the Template.
List of commands:
B2 -> C2:M3
F2 -> V2:AF3
K2 -> V4:AF5
O2 -> M8:R9

So after these commands Template will be printed and repeated with cells B3, F3... until the cells will be blank.

My VBA code looks bad, but I just started with VBA:

Sub Macro3()
Do
If Worksheets("Source").Range("B2").Value > 0 Then
    Sheets("Source").Select
    Range("B2").Select
    Selection.Copy
    Sheets("Template").Select
    Range("C2:M3").Select
    ActiveSheet.Paste
    Sheets("Source").Select
    Range("F2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Template").Select
    Range("V2:AF3").Select
    ActiveSheet.Paste
    Sheets("Source").Select
    Range("K2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Template").Select
    Range("V4:AF5").Select
    ActiveSheet.Paste
    Sheets("Source").Select
    Range("O2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Template").Select
    Range("M8:R9").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
    Sheets("Source").Select
    Range("A2").Select
    Selection.EntireRow.Delete
    Sheets("Template").Select
End If
Loop
End Sub

So for now, my macro is deleting the first row and repeating itself until will stop (but it crashing on the end) and looks very ugly.
Could you help me with this code to look more professional?

Thank you!

 

[TomeK712]

I couldn't find option edit so sorry for replying under my post.

I've made my code little more "sexy" but stil I have no idea how to loop the code with changing the range for Source ranges.

Sub Macro3()
Do
If Worksheets("fmc-data-source-34").Range("B2").Value > 0 Then

        Worksheets("fmc-data-source-34").Range("B2").Copy Worksheets("Template").Range("C2:M3")
        
        Worksheets("fmc-data-source-34").Range("F2").Copy Worksheets("Template").Range("V2:AF3")
        
        Worksheets("fmc-data-source-34").Range("K2").Copy Worksheets("Template").Range("V4:AF5")
        
        Worksheets("fmc-data-source-34").Range("O2").Copy Worksheets("Template").Range("M8:R9")
    
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
    Sheets("fmc-data-source-34").Select
    Range("B2").Select
    Selection.EntireRow.Delete
    Sheets("Template").Select
End If
Loop
End Sub

 

[JackDanIce]

Untested, try:

Sub Macro1()

    Dim x           As Long
    Dim arr()       As Variant
            
    With Sheets("fmc-data-source-34")
        LR = .Cells(.Rows.Count, 2).End(xlUp).row
        arr = .Cells(2, 2).Resize(LR - 1, 14)
    End With
    
    With Worksheets("Template")
        .Select
        Application.ScreenUpdating = False
        For x = LBound(arr, 1) To UBound(arr, 1)
            .Cells(2, 3).Resize(2, 11).Value = arr(x, 1)
            .Cells(2, 22).Resize(2, 11).Value = arr(x, 5)
            .Cells(4, 22).Resize(2, 11).Value = arr(x, 10)
            .Cells(8, 13).Resize(2, 6).Value = arr(x, 15)
            ActiveWindow.SelectedSheets.PrintOut copies:=1, collate:=True, ignoreprintareas:=False
        Next x
        Application.ScreenUpdating = True
    End With
    
    Erase arr
        
End Sub

Suggest using F8 to step through the code, to test it works since you're printing for each loop iteration.

 

[TomeK712]

Thank you for your reply.
Unfortunately, your code is poping-out an error on row:

arr = .Cells(2, 2).Resize(LR - 1, 14)

I've changed little the construction of template, so my VBA code is now:

Sub Macro3()
If Worksheets("fmc-data-source-34").Range("B2").Value > 0 Then
        Worksheets("fmc-data-source-34").Range("B2").Copy Worksheets("Template").Range("C2:M3")
        Worksheets("fmc-data-source-34").Range("F2").Copy Worksheets("Template").Range("T2:AD3")
        Worksheets("fmc-data-source-34").Range("K2").Copy Worksheets("Template").Range("T4:AD5")
        Worksheets("fmc-data-source-34").Range("O2").Copy Worksheets("Template").Range("N8:P9")
    ActiveWindow.SelectedSheets.PrintOut copies:=1, collate:=True, _
        ignoreprintareas:=False
    Worksheets("fmc-data-source-34").Rows(2).Delete
    Sheets("Template").Select
End If
End Sub

It looks little better without selections but still no clue how to loop macro to repeat the process with cells B3, F3, K3, O3 and B4, F4, K4, O4 etc. without erasing the main row.

 

[JackDanIce]

Sorry, that line should end with .Value, try:

Sub Macro1()

    Dim x           As Long
    Dim arr()       As Variant
            
    With Sheets("fmc-data-source-34")
        LR = .Cells(.Rows.Count, 2).End(xlUp).row
        arr = .Cells(2, 2).Resize(LR - 1, 14).Value
    End With
    
    With Worksheets("Template")
        .Select
        Application.ScreenUpdating = False
        For x = LBound(arr, 1) To UBound(arr, 1)
            .Cells(2, 3).Resize(2, 11).Value = arr(x, 1)
            .Cells(2, 22).Resize(2, 11).Value = arr(x, 5)
            .Cells(4, 22).Resize(2, 11).Value = arr(x, 10)
            .Cells(8, 13).Resize(2, 6).Value = arr(x, 15)
            ActiveWindow.SelectedSheets.PrintOut copies:=1, collate:=True, ignoreprintareas:=False
        Next x
        Application.ScreenUpdating = True
    End With
    
    Erase arr
        
End Sub

 

[TomeK712]

Thanks Jack, I've actually found benefits from deleting row each time so I could use parf of your code.

Thred can be closed.

 

[Bayesatthemoon]

Hi guys

I'm using excel in Windows 10 for the first time. When I insert a row and hit Ctrl + Y to add more rows I've encountered a problem. It's fine when I first open the spreadsheet, but as soon as I do any copying or cutting and pasting, the next time I insert a row and do ctrl + Y no more rows are inserted. Anyone have any ideas why that mi