VBA Loop to copy/paste blocks of columns into another worksheet with dynamic range

TheRookie · Nov 9th 2020

Hi everyone,

I usually find my answer here but I've been stuck on this one for several days now.

I'm working on 2 sheets, one with new data, and one with historical data.

On each sheet I have 'blocks' of columns, those blocks are always 4 columns wide, with a blank column in-between. And have different row length.

For example, there are data on column A to D, then a blank column, then data in column F to I, etc. as below:

item 1				item 2
title 1	title 2	title 3	title 4	title 1	title 2	title 3	title4
data	data	data	data	data	data	data	data
data	data	data	data	data	data	data	data
				data	data	data	data

Goal: Need to check if the item number (ex: Cell A1 for the first block) is equal to the item number on the destination sheet (same cell A1).

Need to copy data from row 3 (first row with actual data) until the last row, for the first block of column, onto the 2nd sheet after the last row containing data. And create a loop for each block of columns until the last column of the source sheet.

Issue: The blocks of columns have different row length. Same thing on the destination sheet, each block have different row length. Which is why I need to use a dynamic range, for each block.

My code is here below, I managed to have it working for the first block of column by using the column letters, and try to modify it to use a dynamic range, but it's deleting all the data from row 3 on the destination sheet, and copying '#N/A' from "E3" until the very last column of the excel sheet (it does take into account the number of rows of the first block of column on the source sheet).

Code

Sub copydata()
Dim shta As Worksheet
Dim sht1 As Worksheet
Set shta = Sheets("source")
Set sht1 = Sheets("target")
Dim c As Long
Dim LastCol As Long 'last column sheet source
lrws As Long 'last row of source column
frwt As Long 'first available row in target column
Dim rngs As Range
Dim rngt As Range
Const frsrc As Long = 3 'first row on source column to copy from
For c = 1 To c + 3
If shta.Cells(1, c).Value = sht1.Cells(1, c).Value Then 'ensure data item are the same
lrws = shta.Cells(Rows.Count, c).End(xlUp).Row
frwt = sht1.Cells(Rows.Count, c).End(xlUp).Row + 1
LastCol = shta.Cells(frsrc, Columns.Count).End(xlToLeft).Column
Set rngs = shta.Range(c & frsrc).Resize(lrws, 4) 'source range of first block of columns
Set rngtg = sht1.Range(c & frwt & ":" & c & frwt).Resize(rngs.Rows.Count) 'target range for first block of column
rntg.Value = rngs.Value
c = c + 4 'move to the next block of column
Else: MsgBox "Need to check table formatting"
End If
Next c
End Sub

Display More

There might be a better/easier way of doing it, than moving a block of columns at a time, but that's the only way I could think about.
I'm fairly new to VBA, and would really appreciate any comments/feedback you may have.
Thank you very much in advance!

royUK · Nov 9th 2020

You need to attach an example workbook.

dangelor · Nov 9th 2020

Possibly...

Code

Sub test()
Sheet1.Activate
Cells(1, 1).Select
Do Until Selection.Column = Columns.Count
If Sheet2.Range(Selection.Address) = Selection Then
Selection.CurrentRegion.Offset(2).Copy Sheet2.Cells(Rows.Count, Selection.Column).End(xlUp).Offset(1)
End If
Selection.End(xlToRight).Select
Loop
Cells(1, 1).Select
Sheet2.Activate
End Sub

Display More

TheRookie · Nov 10th 2020

Quote from royUK

You need to attach an example workbook.

Hi royUK as requested, you'll find attached an example workbook. I only kept a certain amount of row/columns for clarity.Example.xlsm
I hope that helps. Thank you very much

dangelor · Nov 10th 2020

Works on your data...

TheRookie · Nov 11th 2020

Hi dangelor ! Sorry for my late reply, I wasn't able to test the code until now. Thank you so much for your feedback, it does exactly what I needed to . Do you reckon there would be a way to optimized the code without activate and select? Because when I run the macro on my full data set, it's a bit slow. I've tried using With sheet 1 instead of Sheet 1.Activate, but it doesn't seem to be working..

TheRookie · Nov 11th 2020

Hi dangelor actually I've just noticed something. I have to do the same operations on 2 sheets (both with 2 different source sheets). It works perfectly on one of them, that has the exact same format as the example I've shared.

But on the other sheet, I noticed there are, for some columns, data on the first row for example C1, L1. So the copy/paste doesn't work properly. It paste the first block correctly, then paste the same data again below the data that has just been pasted 2 columns on the right, etc. and I'm not sure how to fix that issue.
I attached an updated workbook example.Example.xlsm

dangelor · Nov 11th 2020

You could just delete the unwanted column headers on the target worksheet before you run the code.

TheRookie · Nov 11th 2020

I worked on the code and changed it as below, it seems to be working on my data. Let me know what you think

I actually didn't know about the CurrentRegion and wasn't sure how to use Offset, so thank you so much for that

Code

Sub copydata()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim shta As Worksheet, sht1 As Worksheet
Set shta = wb.Sheets("source")
Set sht1 = wb.Sheets("target")
Dim lastcola As Long
Dim i As Integer
With shta
lastcola = shta.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To lastcola Step 5
If shta.Cells(1, i).Value = sht1.Cells(1, i).Value Then
shta.Cells(1, i).CurrentRegion.Offset(2).Copy sht1.Cells(Rows.Count, i).End(xlUp).Offset(1)
Else: MsgBox "Need to check table formatting"
End If
Next i
End With

Display More

dangelor · Nov 11th 2020

If it works for you, it's all good!

VBA Loop to copy/paste blocks of columns into another worksheet with dynamic range

Share

Tags