SOLVED

Merge Sheets von zwei Excel-Datei - Wiederholte Spalten Überschrift

%3CLINGO-SUB%20id%3D%22lingo-sub-2048343%22%20slang%3D%22de-DE%22%3EMerge%20Sheets%20of%20Two%20Excel%20File%20-%20Repeated%20Columns%20Heading%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2048343%22%20slang%3D%22de-DE%22%3E%3CP%3EHello.%20I%20use%20the%20following%20script%20to%20assemble%20my%20file%20monthly.%20this%20works%20fine%2C%20only%20the%20columns%20heading%20is%20imported%20several%20times%20and%20my%20first%20row%20is%20always%20empty.%3C%2FP%3E%3CP%3E%3CSPAN%20class%3D%22lia-inline-image-display-wrapper%20lia-image-align-inline%22%20image-alt%3D%22LBoldrino_0-1610362159397.png%22%20style%3D%22width%3A%20400px%3B%22%3E%3CIMG%20src%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fimage%2Fserverpage%2Fimage-id%2F245202i0F4CD675320A1B28%2Fimage-size%2Fmedium%3Fv%3D1.0%26amp%3Bpx%3D400%22%20role%3D%22button%22%20title%3D%22LBoldrino_0-1610362159397.png%22%20alt%3D%22LBoldrino_0-1610362159397.png%22%20%2F%3E%3C%2FSPAN%3E%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CPRE%20class%3D%22lia-code-sample%20language-visual%22%3E%3CCODE%3ESub%20AddAllWS()%0A%20%20%20%20Dim%20wbDst%20As%20Workbook%0A%20%20%20%20Dim%20wsDst%20As%20Worksheet%0A%20%20%20%20Dim%20wbSrc%20As%20Workbook%0A%20%20%20%20Dim%20wsSrc%20As%20Worksheet%0A%20%20%20%20Dim%20MyPath%20As%20String%0A%20%20%20%20Dim%20strFilename%20As%20String%0A%20%20%20%20Dim%20lLastRow%20As%20Long%0A%0A%20%20%20%20Application.DisplayAlerts%20%3D%20False%0A%20%20%20%20Application.EnableEvents%20%3D%20False%0A%20%20%20%20Application.ScreenUpdating%20%3D%20False%0A%0A%20%20%20%20Set%20wbDst%20%3D%20ThisWorkbook%0A%0A%20%20%20%20MyPath%20%3D%20%22...%5CDqExcels%5CMergTickets%5C%22%0A%20%20%20%20strFilename%20%3D%20Dir(MyPath%20%26amp%3B%20%22*.xls*%22%2C%20vbNormal)%0A%0A%20%20%20%20Do%20While%20strFilename%20%26lt%3B%26gt%3B%20%22%22%0A%0A%20%20%20%20%20%20%20%20%20%20%20%20Set%20wbsrc%3DWorkbooks.Open(MyPath%20%26amp%3B%20strFilename)%0A%0A%20%20%20%20%20%20%20%20%20%20%20%20'loop%20through%20each%20worksheet%20in%20the%20source%20file%0A%20%20%20%20%20%20%20%20%20%20%20%20For%20Each%20wsSrc%20In%20wbSrc.Worksheets%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20'Find%20the%20corresponding%20worksheet%20in%20the%20destination%20with%20the%20same%20name%20as%20the%20source%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20On%20Error%20Resume%20Next%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20Set%20wsDst%20%3D%20wbDst.Worksheets(wsSrc.Name)%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20On%20Error%20GoTo%200%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20If%20wsDst.Name%20%3D%20wsSrc.Name%20Then%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20lLastRow%20%3D%20wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row%20%2B%201%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20wsSrc.UsedRange.Copy%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20wsDst.Range(%22A%22%20%26amp%3B%20lLastRow).PasteSpecial%20xlPasteValues%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20End%20If%0A%20%20%20%20%20%20%20%20%20%20%20%20Next%20wsSrc%0A%0A%20%20%20%20%20%20%20%20%20%20%20%20wbSrc.Close%20False%0A%20%20%20%20%20%20%20%20%20%20%20%20strFilename%20%3D%20Dir()%0A%20%20%20%20Loop%0A%0A%20%20%20%20Application.DisplayAlerts%20%3D%20True%0A%20%20%20%20Application.EnableEvents%20%3D%20True%0A%20%20%20%20Application.ScreenUpdating%20%3D%20True%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3Esomeone%20can%20help%20me%20please!%26nbsp%3B%3C%2FP%3E%3CP%3ELg%20Boldrino%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-2048343%22%20slang%3D%22de-DE%22%3E%3CLINGO-LABEL%3EExcel%3C%2FLINGO-LABEL%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2051113%22%20slang%3D%22en-US%22%3ERe%3A%20Merge%20Sheets%20von%20zwei%20Excel-Datei%20-%20Wiederholte%20Spalten%20%C3%9Cberschrift%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2051113%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F924569%22%20target%3D%22_blank%22%3E%40LBoldrino%3C%2FA%3E%26nbsp%3BI'm%20not%20going%20to%20create%20multiple%20workbooks%20to%20test%20and%20hope%20I%20get%20it%20right...%3C%2FP%3E%3CP%3ETry%20replacing%20the%203%20lines%20inside%20your%20IF%20statement%20with%20this%3A%3C%2FP%3E%3CPRE%20class%3D%22lia-code-sample%20language-applescript%22%3E%3CCODE%3E%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20lLastRow%20%3D%20wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20if%20lLastRow%3D1%20then%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20wsSrc.UsedRange.Copy%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20else%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20lLastRow%20%3D%20lLastRow%20%2B%201%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20wsSrc.Range(%22A2%22%2CwsSrc.Cells(wsSrc.UsedRange.Rows.Count%2CwsSrc.UsedRange.Columns.Count)).Copy%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20end%20if%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20wsDst.Range(%22A%22%20%26amp%3B%20lLastRow).PasteSpecial%20xlPasteValues%3C%2FCODE%3E%3C%2FPRE%3E%3CP%3Ewhat%20I'm%20hoping%20for%20is%20the%20first%20time%20to%20copy%20everything%20including%20the%20header%20but%20each%20time%20after%20start%20on%20row%202%20and%20copy%20everything%20else.%26nbsp%3B%20Again%20I'm%20crossing%20my%20fingers%20I%20didn't%20make%20a%20silly%20mistake...%3C%2FP%3E%3C%2FLINGO-BODY%3E
New Contributor

hallo. ich benutze folgende Script um monatlich meine Datei zusammenzumergen. das funktioniert prima, nur Die Spalten Überschrift wird mehrmals importiert und meine erste zeile ist immer leer.

LBoldrino_0-1610362159397.png

 

 

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

 

kann mir jemand bitte helfen! 

Lg Boldrino

2 Replies
Best Response confirmed by LBoldrino (New Contributor)
Solution

@LBoldrino I'm not going to create multiple workbooks to test and hope I get it right...

Try replacing the 3 lines inside your IF statement with this:

                    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

what I'm hoping for is the first time to copy everything including the header but each time after start on row 2 and copy everything else.  Again I'm crossing my fingers I didn't make a silly mistake...

@mtarler  it works perfekt. thanX!

 how can i remove Duplicates after merging in code??

i do it after merging manually, "Data -> Remove Duplicates -> Select All -> OK"

 

Thanx.