[英]Combine multiple workbooks to one workbook
我需要將多個工作簿合並為一個工作簿。
源工作簿具有唯一的工作表名稱 = "job"
目標工作簿有多個工作表名稱
下面的代碼有兩個問題,
For循環不起作用
目標工作簿中粘貼的數據創建一個新工作表。 但我需要將數據粘貼到現有工作表中。
Sub combine() 'destination worksheets Dim Ar As Worksheet Dim nr As Worksheet Set Ar = ThisWorkbook.Sheets("sheetAr") Set nr = ThisWorkbook.Sheets("Sheetnr") 'Source workbooks Dim FolderPath As String Dim Filename As String Application.ScreenUpdating = False FolderPath = Environ("userprofile" & "\\Desktop\\Copy") Filename = Dir(FolderPath & "*.xlsx*") Do While Filename <> "" Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True Dim ws As Worksheet Dim AW As Workbook Set AW = ActiveWorkbook Set ws= ActiveWorkbook.Sheets("Job") For Each AW In ws AW.Activate Cells.ShownAll ws.Copy Ar Next AW Workbooks(Filename).Close savechanges = True Filename = Dir() Loop Application.ScreenUpdating = True End Sub
FolderPath = Environ("userprofile" & "\\Desktop\\Copy")
應該是FolderPath = Environ("userprofile") & "\\Desktop\\Copy\\"
。 For Each AW In ws
沒有意義,因為AW
是工作簿而ws
是工作表。 您可能指的是For Each ws in AW
但如果只有Job
sheet 是源,則無需循環。 Workbooks(Filename).Close savechanges = True
丟失:
但由於工作簿以只讀方式打開,因此沒有任何更改可保存,因此請使用.Close savechanges := False
。
Option Explicit
Sub combine()
Dim wb As Workbook, rng As Range
Dim wsAr As Worksheet, wsSrc As Worksheet
Dim FolderPath As String, Filename As String
Dim iTargetRow As Long, c As Long, n As Long
FolderPath = Environ("userprofile") & "\Desktop\Copy\"
Filename = Dir(FolderPath & "*.xlsx*")
' destination worksheet
Set wsAr = ThisWorkbook.Sheets("sheetAr")
iTargetRow = wsAr.UsedRange.Row + wsAr.UsedRange.Rows.Count
Application.ScreenUpdating = False
Do While Filename <> ""
Set wb = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
Set wsSrc = wb.Sheets("Job")
Set rng = wsSrc.UsedRange
rng.Copy wsAr.Cells(iTargetRow, rng.Column)
iTargetRow = iTargetRow + rng.Rows.Count
wb.Close savechanges:=False ' opened read only
Filename = Dir()
n = n + 1
Loop
Application.ScreenUpdating = True
MsgBox n & " workbooks scanned", vbInformation
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.