VBA to copy paste data from multiple non contiguous columns

[JARichard74]

I am looking to create a macro that will copy data from sheet "All" to sheet "Calc". P3:P15 from ALL would be copied to Calc F4:F16 for Vendor A; X3:X15 to H4:H16 for Vendor B; and so on for up to 10 vendors. I cannot figure out how to cycle through the Calc sheet and copy paste the Amount data for each vendor. Thanks for your help

Link to the workbook: Test_Workbook.xlsx

 

[DanteAmor]

How about
Adjusts the source columns and destination columns in arrays c1 and c2

Sub CopyData()
  Dim i As Long, c1 As Variant, c2
  c1 = Array("P", "X", "AF")  'columns "All" sheet
  c2 = Array("F", "H", "J")   'columns "Calc" sheet
  For i = 0 To UBound(c1)
    Sheets("All").Range(c1(i) & "3:" & c1(i) & "15").Copy Sheets("Calc").Range(c2(i) & "4")
  Next
End Sub

 

[The_Macrotect]

Hi Richard,

How does this work? This assumes that

1) There will always be a value in the first category under "Amount" in the "ALL" tab And...
2) The vendor info will be spaced exactly as they are in the "ALL" Tab of your test sheet.

Sub Copy_Data_To_Calc()
Dim allcol As Integer, calccol As Integer

allcol = 16
calccol = 6

copyloop:
Range(Sheets("ALL").Cells(3, allcol), Sheets("ALL").Cells(15, allcol)).Copy
Range(Sheets("Calc").Cells(4, calccol), Sheets("Calc").Cells(16, calccol)).PasteSpecial

allcol = allcol + 8
calccol = calccol + 2

If Sheets("ALL").Cells(3, allcol).Value > 0 Then
    GoTo copyloop
End If

End Sub

 

[JARichard74]

How about
Adjusts the source columns and destination columns in arrays c1 and c2

Sub CopyData()
  Dim i As Long, c1 As Variant, c2
  c1 = Array("P", "X", "AF")  'columns "All" sheet
  c2 = Array("F", "H", "J")   'columns "Calc" sheet
  For i = 0 To UBound(c1)
    Sheets("All").Range(c1(i) & "3:" & c1(i) & "15").Copy Sheets("Calc").Range(c2(i) & "4")
  Next
End Sub

Works however, there may be fewer or more than 15 rows. I assume that I can add the columns to c1 and c2 to match the possible 10 vendors. It should also only copy the values to preserve the formatting in Calc. Thanks

 

[JARichard74]

Hi Richard,

How does this work? This assumes that

1) There will always be a value in the first category under "Amount" in the "ALL" tab And...
2) The vendor info will be spaced exactly as they are in the "ALL" Tab of your test sheet.

Sub Copy_Data_To_Calc()
Dim allcol As Integer, calccol As Integer

allcol = 16
calccol = 6

copyloop:
Range(Sheets("ALL").Cells(3, allcol), Sheets("ALL").Cells(15, allcol)).Copy
Range(Sheets("Calc").Cells(4, calccol), Sheets("Calc").Cells(16, calccol)).PasteSpecial

allcol = allcol + 8
calccol = calccol + 2

If Sheets("ALL").Cells(3, allcol).Value > 0 Then
    GoTo copyloop
End If

End Sub

Your two assumptions are correct. The script works well however, I added xlPasteValues as to not lose my formatting in Calc;. the number of items to copy under the Amount ranges will vary i.e. it could be as little as 2 to more than a hundred. For that, I have VBA that creates the Calc sheet with the number of required rows and then I need this to copy the data from the All sheet

 

[DanteAmor]

there may be fewer or more than 15 rows

You seemed like a fixed range in your initial post.

I assume that I can add the columns to c1 and c2 to match the possible 10 vendors.

It is correct as I described it in my post: "Adjusts the source columns and destination columns in arrays c1 and c2"
If there is a pattern you can comment it. With 2 columns, we could assume a different pattern.

It should also only copy the values

Only the values are copied with the following code. I also updated the code to copy to the last row with data.
But you must put the columns of origin and destination.

Sub CopyData()
  Dim i As Long, lr As Long, c1 As Variant, c2 As Variant
  lr = ActiveSheet.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
  c1 = Array("P", "X", "AF")  'columns "All" sheet
  c2 = Array("F", "H", "J")   'columns "Calc" sheet
  For i = 0 To UBound(c1)
    Sheets("Calc").Range(c2(i) & "4").Resize(lr - 2).Value = Sheets("All").Range(c1(i) & "3:" & c1(i) & lr).Value
  Next
End Sub

 

[JARichard74]

You seemed like a fixed range in your initial post.


It is correct as I described it in my post: "Adjusts the source columns and destination columns in arrays c1 and c2"
If there is a pattern you can comment it. With 2 columns, we could assume a different pattern.



Only the values are copied with the following code. I also updated the code to copy to the last row with data.
But you must put the columns of origin and destination.

Sub CopyData()
  Dim i As Long, lr As Long, c1 As Variant, c2 As Variant
  lr = ActiveSheet.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
  c1 = Array("P", "X", "AF")  'columns "All" sheet
  c2 = Array("F", "H", "J")   'columns "Calc" sheet
  For i = 0 To UBound(c1)
    Sheets("Calc").Range(c2(i) & "4").Resize(lr - 2).Value = Sheets("All").Range(c1(i) & "3:" & c1(i) & lr).Value
  Next
End Sub

I have not tested with additional vendors yet, however, the script adds two rows at the bottom of the table in the Calc sheet. I changed your resize to Resize(lr - 4) and it seems to work.

 

[DanteAmor]

I changed your resize to Resize(lr - 4) and it seems to work.

Take the full test and tell me.

 

[JARichard74]

Seems to be working perfectly. Expanded both arrays to cover all ten columns then tested for all scenarios i.e. 1-10 column of data. Worked flawlessly. Thanks much for your help.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.