Loop to paste columns of data into specific locations.

[Ksandra2901]

Hi All

Long time lurker, I've managed to cobble something together from various bits of advice on here, but I just need advice on this last bit....

I have a sheet with columns of data all 34 rows long (managed to find code that turned a long list of numbers into multiple custom sized columns).

The idea is to take each of these columns of 34 locations and put them into a template file that ultimately creates a report for a team to print and check.

So essentially I need to copy and paste each of the columns from one sheet to specific locations on another sheet that could be anything up to 30 cell locations on up to 10 pages?

I hope that makes sense? I am a VBA newbie and I would very much appreciate if an explanation of what each line is doing, so it could help me to learn how to do this myself again at a later date

This is what I have so far, which is copying and pasting like for like on the second sheet, but I need to paste to locations like B7, F7, J7 then drop down to B44, F44, J44 on the next page and repeat until the data runs out? The locations on the receiving sheet will all still be in cols B F and J it will just be the row number that changes?

Option Explicit

Sub Loop_Test()

Dim LCol As Long, x As Long
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets("Helper")
Set sh2 = Sheets("Copy_Location")

    sh1.Select
    Range("A1").Select
              
    LCol = ActiveSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
    For c = 1 To LCol
        sh1.Cells(1, c).Select
        Range(Selection, Selection.End(xlDown)).Copy
        sh2.Cells(1, c).PasteSpecial
        
    Next

End Sub

Source example:

Required Result:

I'm sure it's super easy and I will kick myself but I am stumped....

TIA

 

[Takae]

Hope this helps.

Sub Loop_Test()
    Dim LCol As Long, x As Long, i As Long, LRow As Long
    Dim sh1 As Worksheet, sh2 As Worksheet, c
   
    Application.ScreenUpdating = False
    Set sh1 = Sheets("Helper")
    Set sh2 = Sheets("Copy_Location")
   
    LCol = sh1.Cells(1, Columns.Count).End(xlToLeft).Column 'LastColumn
    LRow = sh1.Cells(Rows.Count, 1).End(xlUp).Row 'LastRow
    x = 2 'The first column=B
    For i = 1 To LCol
        c = sh1.Range(sh1.Cells(1, i), sh1.Cells(LRow, i))
        sh2.Range(sh2.Cells(7, x), sh2.Cells(LRow, x)) = c
        x = x + 4 ' skip three columns
    Next
    Application.ScreenUpdating = True
End Sub

 

[Ksandra2901]

Hope this helps.

Sub Loop_Test()
    Dim LCol As Long, x As Long, i As Long, LRow As Long
    Dim sh1 As Worksheet, sh2 As Worksheet, c
  
    Application.ScreenUpdating = False
    Set sh1 = Sheets("Helper")
    Set sh2 = Sheets("Copy_Location")
  
    LCol = sh1.Cells(1, Columns.Count).End(xlToLeft).Column 'LastColumn
    LRow = sh1.Cells(Rows.Count, 1).End(xlUp).Row 'LastRow
    x = 2 'The first column=B
    For i = 1 To LCol
        c = sh1.Range(sh1.Cells(1, i), sh1.Cells(LRow, i))
        sh2.Range(sh2.Cells(7, x), sh2.Cells(LRow, x)) = c
        x = x + 4 ' skip three columns
    Next
    Application.ScreenUpdating = True
End Sub

Thank you very much for the quick reply. This is very helpful, however i should clarify that I am looking for the loop to run three times skipping columns (as you have done) but then I need every fourth column to return back to Col B but drop down 38 cells ie offsetting back to the beginning but underneath the previous 3 columns? Does that make sense?

Thanks for your efforts so far.

 

[Takae]

Please try this one. This code will paste three times. If you want to paste more, please change [80] as you like.

Sub Loop_Test()
    Dim LCol As Long, x As Long, i As Long, LRow As Long, j As Long
    Dim sh1 As Worksheet, sh2 As Worksheet, c
    
    Application.ScreenUpdating = False
    Set sh1 = Sheets("Helper")
    Set sh2 = Sheets("Copy_Location")
    
    LCol = sh1.Cells(1, Columns.Count).End(xlToLeft).Column 'LastColumn
    LRow = sh1.Cells(Rows.Count, 1).End(xlUp).Row 'LastRow
    
    x = 2 'The first column=B
    For j = 7 To 80 Step 37 'First  row number for pasting
        For i = 1 To LCol
            c = sh1.Range(sh1.Cells(1, i), sh1.Cells(LRow, i))
            sh2.Range(sh2.Cells(j, x), sh2.Cells(LRow + j - 1, x)) = c
            x = x + 4 ' skip three columns
        Next
        x = 2 'Reset =first column(B)
    Next
    Application.ScreenUpdating = True
End Sub