Append Data to Master Dataset

[Merlin_3000]

Hi

Can someone please help me with the below code? I am trying to append data from matching columns in the source file to my target file but I am unable to, The code works fine but appends the data just below the header in target file and not to the last available row. Kindly help

Sub AppendData()


' AppendData Macro


Application.ScreenUpdating = False


' create worksheet objects
 Dim shtSource As Worksheet
Dim shtTarget As Worksheet
Dim strFile As String
Dim LastRow As Range


Set shtTarget = ActiveWorkbook.Sheets("MASTER - Formatted")
strFile = ActiveWorkbook.Worksheets("Macro").Range("C2").Value
If CStr(strFile) <> "False" Then
        
        Set shtSource = Workbooks.Open(strFile).Sheets(1)


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


        shtTarget.Activate
        With shtTarget
            Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("K1:AA1") '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
            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
            shtSource.Activate
            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
            
            
            shtTarget.Activate
           cl.Offset(1, 0).Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value


nextCL:
        Next cl
        
        Application.CutCopyMode = False
            
        shtSource.Activate
        ActiveWorkbook.Close False
                
        
        Else
        
        Application.ScreenUpdating = True


        MsgBox "No valid file selected", vbOKOnly + vbInformation, "Copy Error"
    
        
End If


End Sub

 

[MARK858]

Maybe (untested)....

Sub AppendData()


    ' AppendData Macro


    Application.ScreenUpdating = False


    ' create worksheet objects
    Dim shtSource As Worksheet
    Dim shtTarget As Worksheet
    Dim strFile As String
    Dim LastRow As Range


    Set shtTarget = ActiveWorkbook.Sheets("MASTER - Formatted")
    strFile = ActiveWorkbook.Worksheets("Macro").Range("C2").Value
    If CStr(strFile) <> "False" Then

        Set shtSource = Workbooks.Open(strFile).Sheets(1)


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


        shtTarget.Activate
        With shtTarget
            Dim rngTargetHeaders As Range: Set rngTargetHeaders = .Range("K1:AA1")    '.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
        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
            shtSource.Activate
            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


            shtTarget.Activate
            With shtTarget
                Dim rngPastePoint As Range: Set rngPastePoint = .Cells(.Rows.Count, cl.Column).End(xlUp).Offset(1)    'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
            End With
            rngPastePoint.Resize(rngDataColumn.Rows.Count, rngDataColumn.Columns.Count).Value = rngDataColumn.Value


nextCL:
        Next cl

        Application.CutCopyMode = False

        shtSource.Activate
        ActiveWorkbook.Close False


    Else

        Application.ScreenUpdating = True


        MsgBox "No valid file selected", vbOKOnly + vbInformation, "Copy Error"


    End If


End Sub