我有一个包含许多xls文件的源文件夹。我想创建一个主文件 - 从给定源中的所有文件中将所有信息收集到一个数据库中。
以下代码在主文件中创建2列,并从给定的源文件(一个文件)输入2个值:
Sub getData()
Dim XL As Excel.Application
Dim WBK As Excel.Workbook
Dim scrFile As String
Dim myPath As String
myPath = ThisWorkbook.path & "\db\" 'The source folder
scrFile = myPath & "1.xlsx" 'Select first file
' Sheet name in the master file is "Sh"
ThisWorkbook.Sheets("Sh").Range("A1").Value = "Column 1"
ThisWorkbook.Sheets("Sh").Range("B1").Value = "Column 2"
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
ThisWorkbook.Sheets("Sh").Range("A2").Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B2").Value = WBK.ActiveSheet.Range("C5").Value
WBK.Close False
Set XL = Nothing
Application.ScreenUpdating = True
End Sub
现在我想循环遍历所有文件,并从一个数据库中的每个文件中保存单元格“A10”和“C5”中的值,因此循环应该选择下一行来保存新值。
我知道如何遍历所有文件,但不知道如何切换到下一行:
scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
' Here should be the code to save the values of A10 and C5 of the given file
'in the loop in next available row of the master file.
WBK.Close False
Set XL = Nothing
scrFile = Dir
Loop
任何帮助将受到高度赞赏! :)
答案 0 :(得分:3)
为简单起见,只需使用计数器:
scrFile = Dir(myPath & "*.xlsx")
n = 1 ' skip the first row with headers
Do While scrFile <> ""
n = n + 1
Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)
' save the values of A10 and C5 of the given file in the next row
ThisWorkbook.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B" & n).Value = WBK.ActiveSheet.Range("C5").Value
WBK.Close False
Set XL = Nothing
scrFile = Dir
Loop
msgbox n & " files imported."
顺便说一下,你不需要启动第二个Excel实例(CreateObject(&#34; Excel.Application&#34;))来打开第二个工作簿。这会大大减慢您的代码速度。只需打开,阅读和关闭它。不是通过ThisWorkbook
来解决您的主工作簿,而是为其分配一个变量:
Dim masterWB As Excel.Workbook
set masterWB = ThisWorkbook
...
masterWB.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
答案 1 :(得分:1)
您需要使用End()
函数重新计算循环中的最后一行。
类似于范围.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
或者有一个整数.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
尝试一下:
Sub getData()
Application.ScreenUpdating = False
Dim XL As Excel.Application, _
WBK As Excel.Workbook, _
MS As Worksheet, _
scrFile As String, _
myPath As String
'Sheet name in the master file is "Sh"
Set MS = ThisWorkbook.Sheets("Sh")
'The source folder
myPath = ThisWorkbook.Path & "\db\"
MS.Range("A1").Value = "Column 1"
MS.Range("B1").Value = "Column 2"
Set XL = CreateObject("Excel.Application")
scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""
Set WBK = XL.Workbooks.Open(scrFile)
' Here should be the code to save the values of A10 and C5 of the given file
'in the loop in next available row of the master file.
With MS
.Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("A10").Value
.Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("C5").Value
End With
WBK.Close False
scrFile = Dir
Loop
XL.Quit
Set XL = Nothing
Set MS = Nothing
Set WBK = Nothing
Application.ScreenUpdating = True
End Sub
答案 2 :(得分:0)
我实际上有一个代码,它将遍历每个文件并将代码存入主文件。您还可以选择目标文件夹的目录。
Sub GatherData()
Dim sFolder As String
Application.ScreenUpdating = True
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder..."
.Show
If .SelectedItems.Count > 0 Then
sFolder = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
Call Consolidate(sFolder, ThisWorkbook)
End Sub
Private Sub Consolidate(sFolder As String, wbMaster As Workbook)
Dim wbTarget As Workbook
Dim objFso As Object
Dim objFiles As Object
Dim objSubFolder As Object
Dim objSubFolders As Object
Dim objFile As Object
Dim ary(3) As Variant
Dim lRow As Long
'Set Error Handling
On Error GoTo EarlyExit
'Create objects to enumerate files and folders
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.GetFolder(strFolder).Files
Set objSubFolders = objFso.GetFolder(strFolder).subFolders
'Loop through each file in the folder
For Each objFile In objFiles
If InStr(1, objFile.Path, ".xls") > 0 Then
Set wbTarget = Workbooks.Open(objFile.Path)
With wbTarget.Worksheets(1)
ary(0) = .Range("B8") 'here you can change the cells you need the data from
ary(1) = .Range("B12")
ary(2) = .Range("B14")
End With
With wbMaster.Worksheets(1)
lRow = .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0).Row 'here you can change the row the data is deposited in
.Range("E" & lRow & ":G" & lRow) = ary
End With
wbTarget.Close savechanges:=False
End If
Next objFile
'Request count of files in subfolders
For Each objSubFolder In objSubFolders
Consolidate objSubFolder.Path, wbMaster
Next objSubFolder
EarlyExit:
'Clean up
On Error Resume Next
Set objFile = Nothing
Set objFiles = Nothing
Set objFso = Nothing
On Error GoTo 0
End Sub