我希望有人可以幫助我撰寫代碼。我很確定我已經接近解決這個問題，但我無法弄清楚為什么在代碼運行時會發生某些事情。我的目標：
- 打開一個包含主檔案的目錄
- 打開該檔案并抓住最后一行的位置
- 打開第二個目錄中的作業簿，其中包含多個檔案，每個作業簿中有多個作業表。
- 打開客戶端（第二）目錄中的每個作業簿并檢查每個作業表上的單元格 A33 是否包含資訊。
- 獲取復制范圍的客戶端檔案的最后一行
- 將A33開始的資料復制到U(Lastrow)，粘貼到主檔案的空白行
- 更新主檔案中新的最后一行位置
- 關閉檔案并繼續下一張作業表，如果沒有作業表繼續下一個作業簿并通過該作業簿作業表并重復。
開始 - 所有代碼都運行良好，直到第二個目錄 Do While Loop。
我遇到的第一個問題是我將最后一行的值分配給變數的代碼回傳了錯誤的數字。
'Get the last row of the client worksheet currently opened
clientLR = wsClient.Cells(wsClient.Rows.Count, "A").End(xlUp).Row 'Returns incorrect last row number (7)**
第二個問題是我的 do while 函式在 for each 函式可以獲取下一個檔案之前回圈。
'Loop again to the next file in client directory to be opened
Loop 'Can't call next file without looping to do while statement again which opens same document**
'Call the next file in the client directory to be opened
Next file
這是完整的代碼視圖。
Sub sourceFile2()
Call loopThroughFiles("Z:\Filepath\")
End Sub
Sub loopThroughFiles(ByVal path As String)
Dim fso As Object
Set fso = CreateObject("scripting.FileSystemObject")
Dim folder As Object
Set folder = fso.GetFolder(path)
Dim file As Object
Dim wsOverall As Worksheet
Dim wbOverall As Workbook
Dim overallLR As Long
Dim overallFilepath As String
Dim overallFile As String
Dim wbClient As Workbook
Dim clientLR As Long
Dim wsClient As Worksheet
Dim cellValue As String
'Suppress alerts for clipboard prompt bypass screen updating
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'declare overall file path and file type
overallFilepath = "Z:\Filepath\"
overallFile = Dir(overallFilepath)
'loop through overall file directory
Do While overallFile <> ""
'Open file in overall directory
Set wbOverall = Workbooks.Open(overallFilepath & overallFile)
Set wsOverall = wbOverall.Sheets("Overall")
'Find First Blank Row in overall document
overallLR = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
'Debug.Print overallFile
overallFile = Dir()
'Loop until no files left in directory
Loop
'For each file in the client folder
For Each file In folder.Files
'Loop through the files in client directory until no file is left
Do While file.Name <> ""
DoEvents
'Declare and open the workbook for each file in directory
Set wbClient = Application.Workbooks.Open(path & file.Name)
'For each worksheet in the Client workbook
For Each wsClient In wbClient.Worksheets
'Grab the value of Cell A33 in client workbook to compare
cellValue = Range("A33").Value
'Compare the value of cell A33 in client workbook to make sure it contains data
If cellValue <> "" Then
'Get the last row of the client worksheet currently opened
clientLR = wsClient.Cells(wsClient.Rows.Count, "A").End(xlUp).Row 'Returns incorrect last row number (7)**
'Copy the range all the way to the last row in client worksheet and paste it to the overall documents first blank row
wsClient.Range("A33:U" & clientLR).Copy
wsOverall.Range("A" & overallLR).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'Update new overall documents last row position
overallLR = Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
End If
'Close the current opened workbook
wbClient.Close
'Call the next worksheet in the client file to be copied to the overall document again
Next wsClient
'Loop again to the next file in client directory to be opened
Loop 'Can't call next file without looping to do while statement again which opens same document**
'Call the next file in the client directory to be opened
Next file
'remainder code
'Turn alerts back on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
uj5u.com熱心網友回復：
試試這個（未經測驗，但應該很接近）
Sub sourceFile2()
Call loopThroughFiles("Z:\Filepath\")
End Sub
Sub loopThroughFiles(ByVal path As String)
Const OVERALL_PATH As String = "Z:\Filepath\"
Dim folder As Object, file
Dim wsOverall As Worksheet, wbOverall As Workbook
Dim overallLR As Long, overallFilepath As String
Dim overallFile As String, wbClient As Workbook, xlFiles As Collection
Dim clientLR As Long, wsClient As Worksheet, cellValue As String
overallFile = Dir(OVERALL_PATH & "*.xls*", vbNormal) 'find the "overall" Excel file
If Len(overallFile) = 0 Then
MsgBox "No overall file found"
Exit Sub
End If
Set xlFiles = AllFiles(path, "*.xls*") 'collect all Excel files in `path`
If xlFiles.Count = 0 Then
MsgBox "No files to process", vbExclamation
Exit Sub
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wbOverall = Workbooks.Open(OVERALL_PATH & overallFile)
Set wsOverall = wbOverall.Sheets("Overall")
overallLR = SheetLastRow(wsOverall) 1 'next empty row
For Each file In xlFiles
Set wbClient = Application.Workbooks.Open(file)
For Each wsClient In wbClient.Worksheets
cellValue = wsClient.Range("A33").Value '<<< specify worksheet here!
If Len(cellValue) > 0 Then
clientLR = SheetLastRow(wsClient)
If clientLR >= 33 Then
With wsClient.Range("A33:U" & clientLR)
.Copy
wsOverall.Range("A" & overallLR).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats
overallLR = overallLR .Rows.Count
End With
End If
End If
Next wsClient
wbClient.Close savechanges:=False
Next file
'rest of code...
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
'Return all matching files in `folder` where file name matches `pattern`
Function AllFiles(ByVal folder As String, pattern As String) As Collection
Dim f
Set AllFiles = New Collection
If Right(folder, 1) <> "\" Then folder = folder & "\"
f = Dir(folder & pattern, vbNormal)
Do While Len(f) > 0
AllFiles.Add folder & f
f = Dir()
Loop
End Function
'find the last used row in a sheet
Function SheetLastRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find(what:="*", After:=ws.Cells(1), LookAt:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If Not f Is Nothing Then
SheetLastRow = f.Row 'otherwise 0
Debug.Print "'" & f.Parent.Name & "' in '" & _
f.Parent.Parent.Name & "' = " & f.Address
End If
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/504064.html
上一篇：將范圍合并為CSV