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

Get the data from excel files in sub directories

提问by NewSpeaker

I am new to VBA and to programming in general. This is my first post on this board. I've been working on this for a while modifying code I've found on the internet and I have the code to do what I want, however I would like to modify it slightly to speed up the process.

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

The code I have pulls data from excel files that I deposit in a folder on my desktop "Receiving Temp" and places the data in a workbook "Receiving Data Extractor". I am getting data from about 1000 files a month which are stored in sub-directories that are named for the P.O. they are associated with (varying names). Right now I have to go through each of these sub directories and move the excel files to "Receiving Temp" before the Macro will work. I would like to modify the code to do the same with all excel files contained within sub directories within the folder allowing me to just copy the sub-folders into the "receiving temp" folder and run the macro rather than opening each sub directory and grabbing the excel file and moving it manually. Again, the sub-directories have varying names.

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

I appreciate any help you can offer.

我很感激你能提供的任何帮助。

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

回答by Siddharth Rout

The creation of the array that you are doing has to be inside the ProcessFilesfunction which is taken from here. Once the array is made, rest of your original code ALMOST remains as it is. I had to make changes to GetInfoFromClosedFilefunction as well so when you copy, copy the complete code given below as it is and do not change anything.

您正在执行的数组的创建必须在ProcessFiles从此处获取的函数内。创建数组后，其余的原始代码几乎保持原样。我也必须对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

回答by user3093609

Thank you to both of you!! A simple Bing-search led me to this valuable collection of code, which I was able to adapt and apply within a few minutes. Excellent work!

谢谢两位！！一个简单的必应搜索让我找到了这个有价值的代码集合，我能够在几分钟内适应和应用这些代码。优秀作品！

Any other beginner (as myself) wanting to use this code, note the following necessary changes:

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

ProcessFiles FolderName, "*.xls"

should be changed to "*.xlsx" for excel2010 files.

对于 excel2010 文件，应更改为“*.xlsx”。

In the line:

在行中：

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

and below the similar lines, the "Quality Rep." should be changed to the sheet names where you want to get data from. In the line:

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

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

and below the "Sheet1" should be changed to the sheet name where you want to put the data.

并在“Sheet1”下方应更改为要放置数据的工作表名称。

Apart from that, no changes should be necessary.

除此之外，不需要任何更改。