Excel VBA：在循环中选择一行

Question

我有一个包含许多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 

任何帮助将不胜感激！ :)

Answer 1

为简单起见，只用一个计数器：

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（“Excel.Application”））来打开第二个工作簿。这会让你的代码变慢。只需打开，阅读并关闭它。解决你的主人的工作簿不是ThisWorkbook但varible分配给它：

Dim masterWB As Excel.Workbook 
set masterWB = ThisWorkbook 
... 
masterWB.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value  

Answer 2

您需要重新计算循环中最后一行的功能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 

Answer 3

我其实有一个代码在这里将通过每个文件循环和代码存入您的主文件。您也可以选择目标文件夹的目录。

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