topic Re: Excel Problem: Merge Sheets from More Excel-Files in Developer

Excel Problem: Merge Sheets from More Excel-Files

lboldrino — Mon, 11 Jan 2021 11:18:57 GMT

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

Re: Excel Problem: Merge Sheets from More Excel-Files

Analitika — Mon, 11 Jan 2021 15:39:02 GMT

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

Re: Excel Problem: Merge Sheets from More Excel-Files

lboldrino — Mon, 11 Jan 2021 16:21:05 GMT

dont worked correct..

i have no columnd header and a top blank row 😞

Re: Excel Problem: Merge Sheets from More Excel-Files

lboldrino — Tue, 12 Jan 2021 10:35:50 GMT

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