再請益:如何用VBA公式合併多個Excel表格內容

延續前一次的問題 LINK


小弟試用了網站推薦的公式(主要是因為跟我的需求接近),但在excel表中執行時卻完全不合用(嚴格的說是連合併的動作都沒有完成,所以無從推斷如何改進)。是否能請哪位前輩幫忙看看是什麽問題?感謝

我實際表格類似如下(已移除資料),希望能保留第九列的表頭,並合併不同工作表從B至W行,第十列以下的資料(大部分地域資料都遠超過第40列,圖僅為示例,並不止於第30列)



公式如下:

Sub CombineSheets()

'This macro will copy all rows from the first sheet
'(including headers)
'and on the next sheets will copy only the data
'(starting on row 2)

Dim i As Integer
Dim j As Long
Dim SheetCnt As Integer
Dim lstRow1 As Long
Dim lstRow2 As Long
Dim lstCol As Integer
Dim ws1 As Worksheet

With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With

On Error Resume Next

'Delete the Target Sheet on the document (in case it exists)
Sheets("Target").Delete
'Count the number of sheets on the Workbook
SheetCnt = Worksheets.Count

'Add the Target Sheet
Sheets.Add after:=Worksheets(SheetCnt)
ActiveSheet.Name = "Target"
Set ws1 = Sheets("Target")
lstRow2 = 1
'Define the row where to start copying
'(first sheet will be row 1 to include headers)
j = 1

'Combine the sheets
For i = 1 To SheetCnt
Worksheets(i).Select

'check what is the last column with data
lstCol = ActiveSheet.Cells(1, Activesheet.Columns.Count).End(xlToLeft).Column

'check what is the last row with data
lstRow1 = ActiveSheet.Cells(activesheet.rows.count, "A").End(xlUp).Row

'Define the range to copy
Range("A" & j, Cells(lstRow1, lstCol)).Select

'Copy the data
Selection.Copy
ws1.Range("A" & lstRow2).PasteSpecial
Application.CutCopyMode = False

'Define the new last row on the Target sheet
lstRow2 = ws1.Cells(65536, "A").End(xlUp).Row + 1

'Define the row where to start copying
'(2nd sheet onwards will be row 2 to only get data)
j = 2
Next

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

Sheets("Target").Select
Cells.EntireColumn.AutoFit
Range("A1").Select

End Sub
2013-05-27 14:59 發佈
限制級
您即將進入之討論頁 需滿18歲 方可瀏覽。
根據「電腦網路內容分級處理辦法」修正條文第六條第三款規定,已於該限制級網頁,依台灣網站分級推廣基金會規定作標示。
評分
複製連結