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

我是VBA新手，一般编程。 这是我在这个委员会的第一篇文章。 我一直在这一段时间修改我在互联网上find的代码，我有代码做我想做的，但是我想稍微修改它来加速这个过程。

代码我从excel文件中提取数据，这些文件存放在桌面的“接收温度”文件夹中，并将数据放入工作簿“接收数据提取器”中。 我从每月大约1000个文件中获取数据，这些数据存储在与它们关联的PO命名的子目录（不同的名称）中。 现在，我必须通过这些子目录中的每一个，并将macros文件之前，将Excel文件移动到“接收温度”。 我想修改代码，使其包含在文件夹下的子目录中的所有excel文件相同，只需将子文件夹复制到“receive temp”文件夹中，然后运行macros而不是打开每个子目录并抓取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

你正在做的数组的创build必须在从这里取出的ProcessFiles函数中。 数组一旦完成，其余的原始代码将保持原样。 我必须对GetInfoFromClosedFile函数进行更改，因此在复制时，请按照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

谢谢你们俩！ 一个简单的必应search引导我到这个有价值的代码集合，我可以在几分钟内适应和应用。 优秀作品！

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

 ProcessFiles FolderName, "*.xls" 

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

在该行中：

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

并且在类似的路线下面，“质量Rep”。 应该更改为您要从中获取数据的表单名称。 在该行中：

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

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

除此之外，不需要改变。