从子目录中的excel文件中获取数据

Question

我是 VBA 和一般编程的新手。这是我在这个板上的第一篇文章。我一直在修改我在互联网上找到的代码并且我有代码可以做我想做的事情，但是我想稍微修改它以加快这个过程。

我的代码从我存放在桌面“接收温度”文件夹中的 excel 文件中提取数据，并将数据放入工作簿“接收数据提取器”中。我每月从大约 1000 个文件中获取数据，这些文件存储在以 P.O. 命名的子目录中。它们与（不同的名称）相关联。现在我必须遍历每个子目录并将 excel 文件移动到“接收温度”，然后宏才能工作。我想修改代码以对文件夹内子目录中包含的所有 excel 文件执行相同的操作，从而允许我将子文件夹复制到“接收临时”文件夹并运行宏，而不是打开每个子目录并抓取excel文件并手动移动它。同样，子目录具有不同的名称。

感谢您提供的任何帮助。

Sub ReadDataFromAllWorkbooksInFolder()
    Dim FolderName As String, wbName As String, r As Long
    Dim cValue As Variant, bValue As Variant, aValue As Variant
    Dim dValue As Variant, eValue As Variant, fValue As Variant
    Dim wbList() As String, wbCount As Integer, i As Integer

    FolderName = ThisWorkbook.Path & "\Receiving Temp\"

    ' create list of workbooks in foldername
    wbCount = 0
    wbName = Dir(FolderName & "\" & "*.xls")
    While wbName <> ""
        wbCount = wbCount + 1
        ReDim Preserve wbList(1 To wbCount)
        wbList(wbCount) = wbName
        wbName = Dir
    Wend
    If wbCount = 0 Then Exit Sub
    ' get values from each workbook
    r = 1

    For i = 1 To wbCount
        r = r + 1
        cValue = GetInfoFromClosedFile(FolderName, wbList(i), "Quality Rep.", "c9")
        bValue = GetInfoFromClosedFile(FolderName, wbList(i), "Quality Rep.", "o61")
        aValue = GetInfoFromClosedFile(FolderName, wbList(i), "Quality Rep.", "ae11")
        dValue = GetInfoFromClosedFile(FolderName, wbList(i), "Quality Rep.", "v9")
        eValue = GetInfoFromClosedFile(FolderName, wbList(i), "Quality Rep.", "af3")
        fValue = GetInfoFromClosedFile(FolderName, wbList(i), "Non Compliance", "a1")


         Sheets("Sheet1").Cells(r, 1).Value = cValue
         Sheets("Sheet1").Cells(r, 2).Value = bValue
         Sheets("Sheet1").Cells(r, 3).Value = aValue
         Sheets("Sheet1").Cells(r, 4).Value = dValue
         Sheets("Sheet1").Cells(r, 6).Value = eValue
         Sheets("Sheet1").Cells(r, 5).Value = fValue
     Next i
End Sub

Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
    Dim arg As String

    GetInfoFromClosedFile = ""

    If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\"

    If Dir(wbPath & "\" & wbName) = "" Then Exit Function

    arg = "'" & wbPath & "[" & wbName & "]" & _
          wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)

    On Error Resume Next
    GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function

Answer 1

您正在创建的数组必须在ProcessFiles 函数中，该函数取自here。一旦创建了数组，原始代码的其余部分几乎保持原样。我还必须对 GetInfoFromClosedFile 函数进行更改，因此当您复制时，请照原样复制下面给出的完整代码，不要更改任何内容。

Option Explicit

Dim wbList() As String
Dim wbCount As Long

Sub ReadDataFromAllWorkbooksInFolder()
    Dim FolderName As String
    Dim cValue As Variant, bValue As Variant, aValue As Variant
    Dim dValue As Variant, eValue As Variant, fValue As Variant
    Dim i As Long, r As Long

    FolderName = ThisWorkbook.Path & "\Receiving Temp"

    ProcessFiles FolderName, "*.xls"

    If wbCount = 0 Then Exit Sub

    r = 1

    For i = 1 To UBound(wbList)

        '~~> wbList(i) will give you something like
        '   C:\Receiving Temp\aaa.xls
        '   C:\Receiving Temp\FOLDER1\aaa.xls
        Debug.Print wbList(i)

        r = r + 1
        cValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "c9")
        bValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "o61")
        aValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "ae11")
        dValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "v9")
        eValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "af3")
        fValue = GetInfoFromClosedFile(wbList(i), "Non Compliance", "a1")

        Sheets("Sheet1").Cells(r, 1).Value = cValue
        Sheets("Sheet1").Cells(r, 2).Value = bValue
        Sheets("Sheet1").Cells(r, 3).Value = aValue
        Sheets("Sheet1").Cells(r, 4).Value = dValue
        Sheets("Sheet1").Cells(r, 6).Value = eValue
        Sheets("Sheet1").Cells(r, 5).Value = fValue
     Next i
End Sub

'~~> This function was taken from
'~~> http://www.vbaexpress.com/kb/getarticle.php?kb_id=245
Sub ProcessFiles(strFolder As String, strFilePattern As String)
    Dim strFileName As String, strFolders() As String
    Dim i As Long, iFolderCount As Long

    '~~> Collect child folders
    strFileName = Dir$(strFolder & "\", vbDirectory)
    Do Until strFileName = ""
        If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
            If Left$(strFileName, 1) <> "." Then
                ReDim Preserve strFolders(iFolderCount)
                strFolders(iFolderCount) = strFolder & "\" & strFileName
                iFolderCount = iFolderCount + 1
            End If
        End If
        strFileName = Dir$()
    Loop

    '~~> process files in current folder
    strFileName = Dir$(strFolder & "\" & strFilePattern)
    Do Until strFileName = ""
        wbCount = wbCount + 1
        ReDim Preserve wbList(1 To wbCount)
        wbList(wbCount) = strFolder & "\" & strFileName
        strFileName = Dir$()
    Loop

    '~~> Look through child folders
    For i = 0 To iFolderCount - 1
        ProcessFiles strFolders(i), strFilePattern
    Next i
End Sub

Private Function GetInfoFromClosedFile(ByVal wbFile As String, _
wsName As String, cellRef As String) As Variant
    Dim arg As String, wbPath As String, wbName As String

    GetInfoFromClosedFile = ""

    wbName = FunctionGetFileName(wbFile)
    wbPath = Replace(wbFile, "\" & wbName, "")

    arg = "'" & wbPath & "\[" & wbName & "]" & _
          wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)

    On Error Resume Next
    GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function

'~~> Function to get file name from the full path
'~~> Taken from http://www.ozgrid.com/VBA/GetExcelFileNameFromPath.htm
Function FunctionGetFileName(FullPath As String)
    Dim StrFind As String
    Dim i As Long

    Do Until Left(StrFind, 1) = "\"
        i = i + 1
        StrFind = Right(FullPath, i)
        If i = Len(FullPath) Then Exit Do
    Loop
    FunctionGetFileName = Right(StrFind, Len(StrFind) - 1)
End Function

Answer 2

谢谢你们两个！！一个简单的 Bing 搜索让我找到了这个有价值的代码集合，我能够在几分钟内对其进行调整和应用。干得好！

任何其他想要使用此代码的初学者（如我自己），请注意以下必要的更改：

ProcessFiles FolderName, "*.xls"

excel2010文件应改为“*.xlsx”。

行内：

cValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "c9")

在类似的行之下，“质量代表”。应更改为要从中获取数据的工作表名称。 行内：

    Sheets("Sheet1").Cells(r, 1).Value = cValue

下面的“Sheet1”应该改成你想放数据的工作表名。

除此之外，无需进行任何更改。