एक शीट में कई .xls फ़ाइलों को मर्ज करें - एक्सेल, vba, एक्सेल-vba, मर्ज करें

मेरे पास एक फ़ोल्डर भरा हुआ है।xls फाइलें, सभी फाइलों में समान संरचना (कॉलम नाम) है, मैं चाहता था कि कोड प्रत्येक फ़ाइल को फ़ोल्डर में खोलें और शीट 1 की सामग्री को कॉपी करें और किसी अन्य एक्सेल फाइल में शीट 1 में पेस्ट करें, दूसरी फाइल कॉपी खोलें और शीट में संलग्न करें। 1।

वर्तमान में मेरे पास कोड अलग शीट के रूप में है

  Sub GetSheets()
Path = "C:UsersdtDesktopdt kte"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub

उत्तर:

यह काम कर जाना चाहिए :

Sub GetSheets()
Dim WriteRow As Long, _
LastCell As Range, _
WbDest As Workbook, _
WbSrc As Workbook, _
WsDest As Worksheet, _
WsSrc As Worksheet

Set WbDest = ThisWorkbook
Set WsDest = WbDest.Sheets.Add
WsDest.Cells(1, 1) = "Set your headers here"

Path = "C:UsersdtDesktopdt kte"
Filename = Dir(Path & "*.xls")

Do While Filename <> ""
Set WbSrc = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
Set WsSrc = WbSrc.Sheets(1)
With WsSrc
Set LastCell = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
.Range(.Range("A1"), LastCell).Copy
End With
With WsDest
WriteRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
.Range("A" & WriteRow).Paste
End With

WbSrc.Close
Filename = Dir()
Loop

End Sub