从子目录中的Excel文件获取数据 [英] Get the data from excel files in sub directories

问题描述

我很喜欢VBA和编程。这是我在这个主板上的第一篇文章。我一直在为此修改一段时间修改我在互联网上找到的代码，我有代码来做我想要的，但是我想稍微修改它以加快进程。

我已经从我的桌面接收温度文件夹中存储的Excel文件中提取数据，并将数据放置在工作簿接收数据提取器中。我每月从大约1000个文件获取数据，这些数据存储在以P.O.命名的子目录中。它们与（不同的名称）相关联。现在我必须通过这些子目录中的每一个，并将宏文件移动到接收Temp之前，宏将工作。我想修改代码，对文件夹中的子目录中包含的所有excel文件执行相同操作，只需将子文件夹复制到receive temp文件夹中，并运行宏，而不是打开每个子目录并抓取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\
 
'创建文件夹名称中的工作簿列表
 wbCount = 0 
 wbName = Dir（FolderName&\&*。 xls）
虽然wbName<> 
 wbCount = wbCount + 1 
 ReDim保存wbList（1到wbCount）
 wbList（wbCount）= wbName 
 wbName = Dir 
 Wend 
如果wbCount = 0然后退出Sub 
'从每个工作簿获取值
r = 1 
 
对于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）
 
 
表格（Sheet1）。单元格（r，1）.Value = cValue 
表格（Sheet1）。单元格（r，2）.Value = bValue 
表单（Sheet1）。单元格（r，3）.Value = aValue 
表格（Sheet1）。单元格（r，4）.Value = dValue 
表格（Sheet1 （r，6）.Value = eValue 
 Sheets（Sheet1）。Cells（r，5）.Value = fValue 
 Next i 
 End Sub 
 
私有函数GetInfoFromClosedFile（ByVal wbPath As String，_ 
 wbName As String，wsName As String，cellRef As String）As Variant 
 Dim arg As String 
 
 GetInfoFromClosedFile =
 
如果右（wbPath，1）<> \然后wbPath = wbPath& \
 
如果Dir（wbPath&\& wbName）=然后退出函数
 
 arg ='& wbPath& [& wbName& ]& _ 
 wsName& ！ &安培; Range（cellRef）.Address（True，True，xlR1C1）
 
错误恢复下一步
 GetInfoFromClosedFile = ExecuteExcel4Macro（arg）
结束函数
  

解决方案

您正在做的数组的创建必须位于来自此处的ProcessFiles 功能。阵列制作完成后，您的原始代码ALMOST将保持原样。我必须对 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& \接受温度
 
 ProcessFiles FolderName，* .xls
 
如果wbCount = 0然后退出Sub 
 
r = 1 
 
对于i = 1到UBound（wbList）
 
'~~> wbList（i）会给你一些像
'C：\Receiving Temp\aaa.xls 
'C：\Receiving Temp\FOLDER1\aaa.xls 
调试。打印wbList（i）
 
r = r + 1 
 cValue = GetInfoFromClosedFile（wbList（i），Quality Rep。，c9）
 bValue = GetInfoFromClosedFile（wbList 
 aValue = GetInfoFromClosedFile（wbList（i），Quality Rep。，ae11）
 dValue = GetInfoFromClosedFile（wbList（i）， 
 eValue = GetInfoFromClosedFile（wbList（i），Quality Rep。，af3）
 fValue = GetInfoFromClosedFile（wbList（i），Non Compliance a1）
 
表格（Sheet1）。单元格（r，1）.Value = cValue 
表格（Sheet1）。单元格（r，2）.Value = bValue 
表格（Sheet1）。单元格（r，3）.Value = aValue 
表格（Sheet1）。单元格（r，4）.Value = dValue 
表格（Sheet1 ）.Cells（r，6）.Value = eValue 
 Sh eets（Sheet1）。Cells（r，5）.Value = fValue 
 Next i 
 End Sub 
 
'~~>此功能取自
'~~> 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 
 
'~~>收集子文件夹
 strFileName = Dir $（strFolder&\，vbDirectory）
 Do Until strFileName =
 If（GetAttr（strFolder&\& strFileName ）和vbDirectory）= vbDirectory Then 
如果Left $（strFileName，1）<> 然后
 ReDim保存strFolders（iFolderCount）
 strFolders（iFolderCount）= strFolder& \& strFileName 
 iFolderCount = iFolderCount + 1 
如果
结束If 
 strFileName = Dir $（）
循环
 
'~~>在当前文件夹中处理文件
 strFileName = Dir $（strFolder&\& strFilePattern）
直到strFileName =
 wbCount = wbCount + 1 
 ReDim Preserve wbList（1到wbCount）
 wbList（wbCount）= strFolder& \& strFileName 
 strFileName = Dir $（）
循环
 
'~~>查看子文件夹
 For i = 0 To iFolderCount  -  1 
 ProcessFiles strFolders（i），strFilePattern 
 Next i 
 End Sub 
 
私有函数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 =替换（wbFile，\& wbName，）
 
 arg ='& wbPath& \ [& wbName& ]& _ 
 wsName& ！ &安培; Range（cellRef）.Address（True，True，xlR1C1）
 
关于错误简历Next 
 GetInfoFromClosedFile = ExecuteExcel4Macro（arg）
结束函数
 
' ~~>从完整路径获取文件名的功能
'~~>取自http://www.ozgrid.com/VBA/GetExcelFileNameFromPath.htm 
函数FunctionGetFileName（FullPath As String）
 Dim StrFind As String 
 Dim i As Long 
 
 Do Until Left（StrFind，1）=\
i = i + 1 
 StrFind = Right（FullPath，i）
如果i = Len（FullPath）然后退出Do 
 Loop 
 FunctionGetFileName = Right（StrFind，Len（StrFind） -  1）
结束函数
  

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.

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.

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

解决方案

The creation of the array that you are doing has to be inside the ProcessFiles function 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 GetInfoFromClosedFile function as well so when you copy, copy the complete code given below as it is and do not change anything.

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

这篇关于从子目录中的Excel文件获取数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！