Excel VBA:在循环中选择一行

时间:2015-06-10 09:43:48

标签: excel vba excel-vba

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

任何帮助将受到高度赞赏! :)

3 个答案:

答案 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