VBA Copy and paste Help!

[VBA learner ITG]

Hello,

I was wondering if any of my peers can help me.

I have the below VBA code that looks at Sheet ws2 and copies and paste data by matching the column header in Ws1 into the corresponding columns.

However I can't seem to amend the code so that every time i run the code it pastes data below any other data thats there in the rows.

The code will overwrite current data and i want it to paste only in a blank row under the data thats already there.


Sub copyDataBlocks2()
Dim intErrCount As Integer


' create worksheet objects
Dim shtSource As Worksheet: Set shtSource = Sheets("ws2")
Dim shtTarget As Worksheet: Set shtTarget = Sheets("ws1")


' create range objects
Dim rngSourceHeaders As Range: Set rngSourceHeaders = shtSource.Range("A1:BB1")


With shtTarget
Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("A1:AB1") '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:AB1")
Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, 1).End(xlUp).Offset(1 + 1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
End With


Dim rngDataColumn As Range


' process data
Dim cl As Range, i As Integer
For Each cl In rngTargetHeaders ' loop through each cell in target header row

' identify source location
i = 0 ' reset I
On Error Resume Next ' ignore errors, these are where the value can't be found and will be tested later
i = Application.Match(cl.Value, rngSourceHeaders, 0) 'Finds the matching column name
On Error GoTo 0 ' switch error handling back off

' report if source location not found
If i = 0 Then
intErrCount = intErrCount + 1
Debug.Print "unable to locate item [" & cl.Value & "] at " & cl.Address ' this reports to Immediate Window (Ctrl + G to view)
GoTo nextCL
End If

' create source data range object
With rngSourceHeaders.Cells(1, i)
Set rngDataColumn = Range(.Cells(2, 1), .Cells(1000000, 1).End(xlUp))
End With

' pass to target range object
cl.Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value

nextCL:
Next cl


' confirm process completion and issue any warnings
If intErrCount = 0 Then
MsgBox "process completed", vbInformation
Else
MsgBox "WARNING: " & intErrCount & " issues encountered. Check VBA log for details", vbExclamation
End If


'DELETE ROW WITH BLANK


Dim FoundCell As Range
Application.ScreenUpdating = False
Set FoundCell = Range("A:A").Find(What:="")
Do Until FoundCell Is Nothing
FoundCell.EntireRow.Delete
Set FoundCell = Range("Q:Q").FindNext

Loop


End Sub

 

[VBA learner ITG]

I think this is the line of code thats failing and not looking for an empty row and pastes the data into that empty row downwards:

With shtTarget
Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("A1:AB1") '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:AB1")
Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, 1).End(xlUp).Offset(1 + 1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
EndWith

 

[VBA learner ITG]

Can any of my peers help!

 

[MARK858]

Try changing

cl.Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value

to

Cells(Rows.Count, cl.Column).End(xlUp).Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value

 

[Fuisdale2]

Hi Mark858,

I have tried your amended code and unfortunately, it doesnt work.

When I replace that VBA string it doesn't look up and copy/paste any data into the "ws1" tab like the previous code.

The code also duplicates the data in "ws2".

Thank you again for your input.

 

[MARK858]

Hi Mark858,

When I replace that VBA string it doesn't look up and copy/paste any data into the "ws1" tab like the previous code.

The code also duplicates the data in "ws2".

Very strange as all the amendment does is move the destination start cell to the last cell in the same column. It doesn't make any changes to the source data or make any other changes so if you are getting duplicates then you need to look at the rest of the code.

I will leave it to someone else to give some ideas.

 

[Fuisdale2]

Hi Mark858,

Thank you for looking

 

[MARK858]

Before I leave the thread what happens with

shtTarget.Cells(Rows.Count, cl.Column).End(xlUp).Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value

 

[Fuisdale2]

Hi Mark858,

I don't know what to say, but you cracked it.

You don't know how much you have helped me out today.

Thank you so much. If you are ever in Manchester, UK I owe you a drink.

Thank you