Copy/Paste Data based on Headers to next empty Row

[clazzic]

Hi guys,

i've got this code that works brilliantly when wanting to import data from a Source sheet to a Target sheet based on Target headers. Only problem i have is when there is new data in the Source sheet, it copies over and replaces the data in the Target sheet.

What i want it to do is to keep all the current functions the same but when it copies it copies to the next empty row on the target sheet when new data is added in the source sheet.

Thanks for your help.

This is part of the code that i think is related but doesnt seem to copy to next empty row.

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

This is the full code for your references

Sub ImportD()Dim intErrCount As Integer


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


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




With shtTarget
   ' Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("A5:AW5") '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:C1")
    Dim rngTargetHeaders As Range: Set rngTargetHeaders = Intersect(.Rows(4), .UsedRange)
    Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, 1).End(xlUp).Offset(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 "Import Data completed", vbInformation
Else
   ' MsgBox "WARNING: " & intErrCount & " issues encountered. Check VBA log for details", vbExclamation
    MsgBox "Import Data completed", vbInformation
End If
End Sub

 

[frank_AL]

clazzic, I use a very simple approach to find the last row and then select the row below that.
In the line that starts with "LastRow" change the column designation to whichever column is appropriate for your target WorkSheet.
For this example I have set it to column "A"

Dim LastRow as Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & LastRow + 1).Select

 

[clazzic]

Hi Frank,

How would i incorporate that into my existing code i am a complete beginner at vba.