Skip to main content
cancel
Showing results for 
Search instead for 
Did you mean: 

Register now to learn Fabric in free live sessions led by the best Microsoft experts. From Apr 16 to May 9, in English and Spanish.

Reply
lboldrino
Resolver I
Resolver I

Excel Problem: Merge Sheets from More Excel-Files

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

 

1 ACCEPTED SOLUTION
lboldrino
Resolver I
Resolver I

 

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

 

View solution in original post

3 REPLIES 3
lboldrino
Resolver I
Resolver I

 

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
Post Prodigy
Post Prodigy

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

dont worked correct..

i have no columnd header and a top blank row  😞

lboldrino_0-1610382034717.png

 

Helpful resources

Announcements
Microsoft Fabric Learn Together

Microsoft Fabric Learn Together

Covering the world! 9:00-10:30 AM Sydney, 4:00-5:30 PM CET (Paris/Berlin), 7:00-8:30 PM Mexico City

PBI_APRIL_CAROUSEL1

Power BI Monthly Update - April 2024

Check out the April 2024 Power BI update to learn about new features.

April Fabric Community Update

Fabric Community Update - April 2024

Find out what's new and trending in the Fabric Community.