Merging the sheets in one master sheet which already has column headers-CodePudding

I am merging the excels from a folder to a target file based on column headers in target file. I am facing an issue, it paste the data column wise so if in 1st source sheet column "b" has no data, then it will be empty in target file. and when it try to merge the 2nd source sheet into the target sheet, it is pasting the data in b column from 2nd row only becuase for 1st sheet this column was empty. I tried different ways but i am not getting right output. And also i want to get the source file name in column "FI" of target sheet for each row.

Sub Test()
  Dim wb As Workbook
Dim wa As Workbook
Dim ws_A As Worksheet
Dim ws_B As Worksheet
Dim FileFold As String
Dim FileSpec As String
Dim FileName As String
Dim sFile As String
Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant
Dim rowTarget As Long
    FileFold = "C:\Users\kk\Desktop\Merged files\"
    FileSpec = FileFold & Application.PathSeparator & "*.xlsx*"
    FileName = Dir(FileSpec)
        If FileName = vbNullString Then
        MsgBox Prompt:="No files were found that match " & FileSpec, Buttons:=vbCritical, Title:="Error"
        Exit Sub
        End If
Dim i As Long
Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long
    sFile = Dir(FileFold & "*.xls*")
Do Until sFile = ""
    Set wb = Workbooks("CD")
    Set wa = Workbooks.Open(FileName:=FileFold & Application.PathSeparator & sFile, UpdateLinks:=False)
    Set ws_A = wa.Worksheets("Steel")
    Set ws_B = wb.Worksheets("Sheet1")
    Set NameList_A = CreateObject("Scripting.Dictionary")
       With ws_A
        SourceDataStart = 2
        HeaderRow_A = 1
        TableColStart_A = 1
        HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column
        For i = TableColStart_A To HeaderLastColumn_A
        If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then
        NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i
        End If
            Next i
       End With

      With ws_B
        ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column
        For i = 1 To ws_B_lastCol
        SourceCol_A = NameList_A(UCase(.Cells(1, i).Value))

        If SourceCol_A <> 0 Then
            SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
            Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
            NextEntryline = .Cells(Rows.Count, i).End(xlUp).Row   1

            .Range(.Cells(NextEntryline, i), _
                   .Cells(NextEntryline, i)) _
                   .Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
        End If

        Next i
        End With
        wa.Close SaveChanges:=False
        sFile = Dir()
Loop

  errHandler:
    On Error Resume Next
     Application.ScreenUpdating = True


     Set wsSource = Nothing
       Set wbSource = Nothing
    Set wsTarget = Nothing
    End Sub

       Private Function FileFolderExists(strPath As String) As Boolean
       If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
    End Function

I am trying to change here- *NextEntryline = .Cells(Rows.Count, i).End(xlUp).Row 1

.Range(.Cells(NextEntryline, i), _ .Cells(NextEntryline, i)) _ .Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value*

When i tried to change it to last row then its pasting the data from where previous column ends.

CodePudding user response：

This is your original code with indentation for easier readability and my aditional lines of code as specified clearly further below. I'm autistic so I can sound like I'm schooling others when I'm just trying to help.

I haven't tested this code; but this is my idea for resolving your request

Sub Test()

Dim wb As Workbook
Dim wa As Workbook
Dim ws_A As Worksheet
Dim ws_B As Worksheet
Dim FileFold As String
Dim FileSpec As String
Dim FileName As String
Dim sFile As String
Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant
Dim rowTarget As Long
Dim iHighestUsedRow&
    FileFold = "C:\Users\kk\Desktop\Merged files\"
    FileSpec = FileFold & Application.PathSeparator & "*.xlsx*"
    FileName = Dir(FileSpec)
    
    If FileName = vbNullString Then
        MsgBox Prompt:="No files were found that match " & FileSpec, Buttons:=vbCritical, Title:="Error"
        Exit Sub
    End If
    
Dim i As Long
Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long
    sFile = Dir(FileFold & "*.xls*")
    
    Do Until sFile = ""
        Set wb = Workbooks("CD")
        Set wa = Workbooks.Open(FileName:=FileFold & Application.PathSeparator & sFile, UpdateLinks:=False)
        Set ws_A = wa.Worksheets("Steel")
        Set ws_B = wb.Worksheets("Sheet1")
        Set NameList_A = CreateObject("Scripting.Dictionary")
        
        With ws_A
            SourceDataStart = 2
            HeaderRow_A = 1
            TableColStart_A = 1
            HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.count).End(xlToLeft).Column
            
            iHighestUsedRow = 0
            
            For i = TableColStart_A To HeaderLastColumn_A
                If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).value)) Then
                    NameList_A.Add UCase(.Cells(HeaderRow_A, i).value), i
                End If
            Next i
        End With

        With ws_B
            ws_B_lastCol = .Cells(HeaderRow_A, Columns.count).End(xlToLeft).Column
            
            For i = 1 To ws_B_lastCol
                SourceLastRow = .Cells(Rows.count, i).End(xlUp).Row
                
                If SourceLastRow > iHighestUsedRow Then
                    iHighestUsedRow = SourceLastRow
                End If
            Next i
        End With

        With ws_B
            For i = 1 To ws_B_lastCol
                SourceCol_A = NameList_A(UCase(.Cells(1, i).value))
        
                If SourceCol_A <> 0 Then
                    SourceLastRow = ws_A.Cells(Rows.count, SourceCol_A).End(xlUp).Row
                    
                    If SourceLastRow > 1 Then
                        Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
'                        NextEntryline = .Cells(Rows.count, i).End(xlUp).Row   1
                        NextEntryline = iHighestUsedRow   1
            
                        .Range(.Cells(NextEntryline, i), _
                               .Cells(NextEntryline, i)) _
                               .Resize(Source.Rows.count, Source.Columns.count).Cells.value = Source.Cells.value
                    End If
                End If
    
            Next i
        End With
        
        wa.Close SaveChanges:=False
        sFile = Dir()
    Loop

errHandler:
    On Error Resume Next
        Application.ScreenUpdating = True

    Set wsSource = Nothing
    Set wbSource = Nothing
    Set wsTarget = Nothing
End Sub

Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

My additional lines of code inserted above to record and apply the highest used row

    Dim iHighestUsedRow&
    
                    iHighestUsedRow = 0

        With ws_B
            ws_B_lastCol = .Cells(HeaderRow_A, Columns.count).End(xlToLeft).Column
            
            For i = 1 To ws_B_lastCol
                SourceLastRow = .Cells(Rows.count, i).End(xlUp).Row
                
                If SourceLastRow > iHighestUsedRow Then
                    iHighestUsedRow = SourceLastRow
                End If
            Next i
        End With

                    If SourceLastRow > 1 Then
'                        NextEntryline = .Cells(Rows.count, i).End(xlUp).Row   1
                        NextEntryline = iHighestUsedRow   1
                    End If

If you place a breakpoint on this line, before running your code

                        NextEntryline = iHighestUsedRow   1

you can verify that iHighestUsedRow is being set to the correct value in the macro