Excel Problem: Merge Sheets from More Excel-Files

[lboldrino]

i use this modul for merge my Tickets monthly. this works good but with duplicate header names. and the first row ist black.

any idea??

thanx 🙂

Sub AddAllWS()
    Dim wbDst As Workbook
    Dim wsDst As Worksheet
    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet
    Dim MyPath As String
    Dim strFilename As String
    Dim lLastRow As Long

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set wbDst = ThisWorkbook

    MyPath = "....\DqExcels\MergTickets\"
    strFilename = Dir(MyPath & "*.xls*", vbNormal)

    Do While strFilename <> ""

            Set wbsrc=Workbooks.Open(MyPath & strFilename)

            'loop through each worksheet in the source file
            For Each wsSrc In wbSrc.Worksheets
                'Find the corresponding worksheet in the destination with the same name as the source
                On Error Resume Next
                Set wsDst = wbDst.Worksheets(wsSrc.Name)
                On Error GoTo 0
                If wsDst.Name = wsSrc.Name Then
                    lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
                    wsSrc.UsedRange.Copy
                    wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues
                End If
            Next wsSrc

            wbSrc.Close False
            strFilename = Dir()
    Loop

    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[lboldrino · Accepted solution]

Sub AddAllWS()
    Dim wbDst As Workbook
    Dim wsDst As Worksheet
    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet
    Dim MyPath As String
    Dim strFilename As String
    Dim lLastRow As Long

    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set wbDst = ThisWorkbook

    MyPath = "..\DqExcels\MergTickets\"
    strFilename = Dir(MyPath & "*.xls*", vbNormal)

    Do While strFilename <> ""

            Set wbsrc=Workbooks.Open(MyPath & strFilename)

            'loop through each worksheet in the source file
            For Each wsSrc In wbSrc.Worksheets
                'Find the corresponding worksheet in the destination with the same name as the source
                On Error Resume Next
                Set wsDst = wbDst.Worksheets(wsSrc.Name)
                On Error GoTo 0

                If wsDst.Name = wsSrc.Name Then
   			lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row
                  	  if lLastRow=1 then
                     		  wsSrc.UsedRange.Copy
                  	  else
                    	  lLastRow = lLastRow + 1
                       	  wsSrc.Range("A2",wsSrc.Cells(wsSrc.UsedRange.Rows.Count,wsSrc.UsedRange.Columns.Count)).Copy
                   	 end if
                    	wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues
                End If

            Next wsSrc

            wbSrc.Close False
            strFilename = Dir()
    Loop

    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

[Analitika]

Try instead

wsSrc.UsedRange.Copy
wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues

post this

Set rng = wsSrc.UsedRange
Intersect(rng, rng.Offset(1)).Copy wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues

[lboldrino]

dont worked correct..

i have no columnd header and a top blank row  😞