问题
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
回答1:
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
回答2:
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.
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.
Apart from that, no changes should be necessary.
来源：https://stackoverflow.com/questions/10898782/get-the-data-from-excel-files-in-sub-directories