遍歷范圍內的每個工作簿

Question

我有一列中包含Excel工作簿文件路徑和文件名的工作簿：

C:\D\Folder1\File1.xls
C:\D\Folder2\File2.xls
C:\D\Folder3\File3.xls

每個文件及其文件路徑均從上述目錄中提取。

這些工作簿中的每一個都在單元格C15中包含一個電子郵件地址，我想將其復制並粘貼到工作簿的相鄰單元格中，如下所示：

C:D\\Folder1\File1.xls       email@email.com
C:\D\Folder2\File2.xls       email@email.com
C:\D\Folder3\File3.xls       email@email.com

我的代碼僅檢查一個工作簿並在單元格D17中獲取一個電子郵件地址：

C:\D\Folder1\File1.xls       email@email.com
C:\D\Folder2\File2.xls       
C:\D\Folder3\File3.xls   

如何遍歷列表中的每個工作簿。

這是我的代碼：

Sub SO()

Dim parentFolder As String

parentFolder = Range("F11").Value & "\" '// change as required, keep trailing slash

Dim results As String

results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & parentFolder & "*.*"" /S /B /A:-D").StdOut.ReadAll

Debug.Print results

'// uncomment to dump results into column A of spreadsheet instead:
Range("D17").Resize(UBound(Split(results, vbCrLf)), 1).Value = WorksheetFunction.Transpose(Split(results, vbCrLf))
Range("Z17").Resize(UBound(Split(results, vbCrLf)), 1).Value = "Remove"
'//-----------------------------------------------------------------
'// uncomment to filter certain files from results.
'// Const filterType As String = "*.exe"
'// Dim filterResults As String
'//
'// filterResults = Join(Filter(Split(results, vbCrLf), filterType), vbCrLf)
'//
'// Debug.Print filterResults
On Error GoTo errHandler
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False


Dim app As New Excel.Application
app.Visible = False 'Visible is False by default, so this isn't necessary

Dim x As Workbook
Dim y As Workbook

'## Open both workbooks first:
Set x = Workbooks.Open(Range("D17").Value)
Set y = ThisWorkbook

'Now, copy what you want from x:
x.Worksheets(1).Range("C15").Copy

'Now, paste to y worksheet:
y.Worksheets(1).Range("U17").PasteSpecial xlPasteValues

'Close x:
x.Close


Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

errHandler:
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

End Sub

Answer 1

就像Vincent G所說的那樣，您的錯誤處理程序不好，如果在文件中循環訪問，則不妨使用Dir（它快速且易於使用）。 您可能會發現拆分任務更加容易。 我已經修改了一些備用的代碼，我認為它將滿足您的需求。 如果您不明白，那就問一下。

Sub DirectoryLoop()
Dim FileName As String, FilePath As String, TargetValue As String, HomeFile As String
HomeFile = "TestBook.xlsx"
FilePath = "C:\"
FileName = dir(FilePath & "\", vbNormal)
Do While FileName <> ""
    TargetValue = GetInfo(FileName, FilePath)
    WriteInfo TargetValue, HomeFile
    FileName = dir
Loop
End Sub
Function GetInfo(ByRef TargetFile As String, ByRef Folder As String) As String
    Workbooks.Open Folder & "\" & TargetFile
    GetInfo = Workbooks(TargetFile).Worksheets(1).Range("D17").value
    Workbooks(TargetFile).Close
End Function
Sub WriteInfo(ByRef TargetVal As String, HomeWorkbook As String)
    With Workbooks(HomeWorkbook).sheets(1)
        .Range("U" & .rows.count).End(xlUp).value = TargetVal
    End With
End Sub

Answer 2

下面的代碼應該工作。 我不確切知道您想對Z列中的remove做什么，所以我只是將它復制到excel文件的所有行中。

在這里，我認為活動表是worksheets（1）。

Sub SO()
    Dim parentFolder As String
    Dim filename As String
    Dim wb As Workbook
    parentFolder = Range("F11").Value & "\"

    'On Error GoTo errHandler

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    filename = Dir$(parentFolder & "*.*")
    Dim currentRow As Long
    currentRow = 17
    Do While Len(filename) > 0
        Cells(currentRow, 4).Value = filename ' 4 is U column
        'this will fail if file is not excel file
        Set wb = Workbooks.Open(parentFolder & filename)
        Cells(currentRow, 21).Value = wb.Worksheets(1).Range("C15").Value ' 21 is U column
        wb.Close
        cells(currentRow,26).Value = "Remove"
next_file:
        filename = Dir$
        currentRow = currentRow + 1
    Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True

    Exit Sub
errHandler:
    'in case of error we skip and go to the next file.
    Resume next_file
End Sub

Answer 3

另一個解決方案：

Option Explicit

'Modify as needed
Const EXCELPATH = "C:\Temp\SO\"
Const EXCELFILES = "*.xls"
Const EMAILCELL = "D15"
Const SHEETNAME = "Sheet1"

Sub GetEmails()
    Dim XL As Object        'Excel.Application
    Dim WB As Object        'Excel.Workbooks
    Dim WS As Object        'Excel.Worksheet
    Dim theCell As Range
    Dim theFile As String
    Dim theExcelFile As String

    Set XL = CreateObject("Excel.Application")
    theFile = Dir(EXCELPATH & EXCELFILES)
    Do While theFile <> ""
        theExcelFile = EXCELPATH & theFile
        Set WB = OpenWorkbook(XL, theExcelFile)
        Set WS = WB.Sheets(SHEETNAME)
    '*
    '* Get the email address in EMAILCELL
    '*
    Set theCell = WS.Range(EMAILCELL)
    Debug.Print "Email from " & theExcelFile & ": " & theCell.Value
    '*
    '* Handle the email address as desired
    '*
    '...... your code .....
    '
    theFile = Dir() 'Next file if any
    Loop
End Sub
'******************************************
'* Return WB as Workbook object
'* XL is an Excel application object
'*
Function OpenWorkbook(XL As Object, Filename As String) As Object
    Dim i As Integer

    Set OpenWorkbook = XL.Workbooks.Open(Filename)
    OpenWorkbook.Activate
    '*
    '* Wait until the  Excel file is open.
    '*
    i = 10
    Do While IsFileOpen(Filename) = False
        i = i - 1
        If i = 0 Then Exit Do
    Loop
    If i = 0 Then MsgBox "Error opening Excel file:" & vbCrLf & Filename
End Function
'*********************************************************************************************************************
'* Check if an Office file is open
'* Reference: http://accessexperts.com/blog/2012/03/06/checking-if-files-are-locked
'* Short story: "small" applications like Notepad do not lock opened files whereas Office applications do
'* The below code tests if a file is locked
'*
Function IsFileOpen(Filename As String) As Boolean
    Dim n As Integer

    IsFileOpen = False
    n = FreeFile() 'Next free
    On Error GoTo Opened

    Open Filename For Random Access Read Write Lock Read Write As #n  'Error if locked
    Close n    'Not locked
    Exit Function

Opened:
    IsFileOpen = True
    On Error GoTo 0
End Function

Answer 4

您的問題尚不清楚（這就是為什么每個人都給您Dir()解決方案的原因）。

我想您是說您的工作表中已經有路徑和文件名的列表，您只是想用這些文件中的某個單元格值填充工作表的每一行。 您可以通過多種方式來執行此操作，而不必每次都真正打開工作簿（例如，使用單元格公式，使用ADO ， ExecuteExcel4Macro() ）。 這些中的任何一個都會為您服務。

我的個人偏好是“原始” ADO因為我可以更好地控制錯誤處理並檢查表名，工作表名等。下面的代碼顯示ExecuteExcel4Macro()如何工作（語法更簡單，可能更適合為了你）。 您必須在代碼的第一行中將工作表的名稱更改為工作表名稱，並在第二行中將文件名的第一個單元格的范圍地址更改為。

Dim startCell As Range, fileRng As Range
Dim files As Variant, values() As Variant
Dim path As String, file As String, arg As String
Dim r As Long, i As Long

'Acquire the names of your files
With ThisWorkbook.Worksheets("Sheet1") 'amend to your sheet name
    Set startCell = .Range("F11") 'amend to start cell of file names
    Set fileRng = .Range(startCell, .Cells(.Rows.Count, startCell.Column).End(xlUp))
End With
files = fileRng.Value2

'Size your output array
ReDim values(1 To UBound(files, 1), 1 To 1)

'Populate output array with values from workbooks
For r = 1 To UBound(files, 1)
    'Create argument to read workbook value
    i = InStrRev(files(r, 1), "\")
    path = Left(files(r, 1), i)
    file = Right(files(r, 1), Len(files(r, 1)) - i)
    arg = "'" & path & "[" & file & "]Sheet1'!R15C3"
    'Acquire the value
    values(r, 1) = ExecuteExcel4Macro(arg)
Next

'Write values to sheet
fileRng.Offset(, 1).Value = values