我是VBA的新手和一般的编程。这是我在这个董事会上的第一篇文章。我一直在努力修改我在互联网上找到的代码并且我有代码来做我想要的，但是我想稍微修改它以加快这个过程。
我从excel文件中提取数据的代码存放在桌面“Receiving Temp”的文件夹中，并将数据放在工作簿“Receiving Data Extractor”中。我每月从大约1000个文件中获取数据，这些文件存储在以P.O.命名的子目录中。它们与（不同的名称）相关联。现在，我必须遍历每个子目录，并在宏工作之前将excel文件移动到“接收温度”。我想修改代码以对文件夹中子目录中包含的所有excel文件执行相同操作，这样我只需将子文件夹复制到“receiver 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\"
' 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
答案 0 :(得分：2)
您正在执行的数组的创建必须位于ProcessFiles函数中，该函数取自here。一旦完成阵列，原始代码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 & "\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
答案 1 :(得分：0)
谢谢你们两位！一个简单的Bing搜索让我获得了这个有价值的代码集合，我能够在几分钟内完成并适用。出色的工作！
任何其他想要使用此代码的初学者（如我自己），请注意以下必要的更改：
ProcessFiles FolderName, "*.xls"
应更改为“* .xlsx”。
在行中：
cValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "c9")
以及类似的行，“质量代表”。应更改为要从中获取数据的工作表名称。 在该行：
Sheets("Sheet1").Cells(r, 1).Value = cValue
和“Sheet1”下方应更改为您要放置数据的工作表名称。
除此之外，不需要进行任何更改。