Question

我正在尝试将数据库中存在的几个工作簿中的数据复制到单个工作簿中。我循环遍历文件夹以从各种工作簿中获取数据，但我需要在循环中粘贴从A5：D5跨越的数据。即A5：目的表中的D5是文件夹中的一个工作簿的数据，我需要将另一组数据复制到A6：D6中，以便文件夹中的工作簿数量。请帮我解决这个问题。

    Private Sub CommandButton1_Click()
    Dim wbk As Workbook
    Dim Filename As String
    Dim Path As String
    Path = "D:\Macro_Demo\estimation_sheets\"
    Filename = Dir(Path & "*.xls")
    Set target = Workbooks.Open("D:\Macro_Demo\Metrics_Macro_dest")
    '--------------------------------------------
    'OPEN EXCEL FILES
     Do While Len(Filename) > 0  'IF NEXT FILE EXISTS THEN
     Set wbk = Workbooks.Open(Path & Filename)
      target.Sheets("Metrics_Data").Range("A5").Value = wbk.Sheets("summary").Range("I5").Value
     target.Sheets("Metrics_Data").Range("B5").Value = wbk.Sheets("summary").Range("I6").Value + wbk.Sheets("summary").Range("I7")
     target.Sheets("Metrics_Data").Range("C5").Value = wbk.Sheets("summary").Range("I8").Value
     target.Sheets("Metrics_Data").Range("D5").Value = wbk.Sheets("summary").Range("I9").Value
      MsgBox Filename & " has opened"
      wbk.Close True
      Filename = Dir
      Loop

      MsgBox "Task complete!"
      End Sub

Answer 1

试试这个：

Private Sub CommandButton1_Click()
    Dim wbk As Workbook, target As Workbook, excelFile As String, path As String, rw As Integer

    path = "D:\Macro_Demo\estimation_sheets\"
    excelFile = Dir(path & "*.xls")
    rw = 5

    Set target = Workbooks.Open("D:\Macro_Demo\Metrics_Macro_dest")

    Do While excelFile <> ""
        Set wbk = Workbooks.Open(path & excelFile)

        With target.Sheets("Metrics_Data")
            .Range("A" & rw) = wbk.Sheets("summary").Range("I5")
            .Range("B" & rw) = wbk.Sheets("summary").Range("I6") + wbk.Sheets("summary").Range("I7")
            .Range("C" & rw) = wbk.Sheets("summary").Range("I8")
            .Range("D" & rw) = wbk.Sheets("summary").Range("I9")
        End With

        wbk.Close True

        rw = rw + 1
        excelFile = Dir
    Loop

    MsgBox "Task complete!"
End Sub

Answer 2

您需要在目标工作表上找到下一个可用行，将其存储在变量中，然后写入相对于该单元格的数据。喜欢这个

Private Sub CommandButton1_Click()

    Dim shSource As Worksheet, shDest As Worksheet
    Dim sFile As String
    Dim rNextRow As Range

    Const sPATH As String = "D:\Macro_Demo\estimation_sheets\"

    'Open the destination workbook
    Set shDest = Workbooks.Open("D:\Macro_Demo\Metrics_Macro_dest.xls").Worksheets("Metrics_Data")

    sFile = Dir(sPATH & "*.xls")

    Do While Len(sFile) > 0
        Set shSource = Workbooks.Open(sPATH & sFile).Worksheets("summary")

        'start at row 1000 and go up until you find something
        'then go down one row
        Set rNextRow = shDest.Cells(1000, 1).End(xlUp).Offset(1, 0)

        'Write the values relative to rNextRow
        With rNextRow
            .Value = shSource.Range("I5").Value
            .Offset(0, 1).Value = shSource.Range("I6").Value
            .Offset(0, 2).Value = shSource.Range("I8").Value
            .Offset(0, 3).Value = shSource.Range("I9").Value
        End With

        'Close the source
        shSource.Parent.Close False

        sFile = Dir
    Loop

    MsgBox "Done"

End Sub

将数据从工作簿文件夹复制到VBA中的循环中的单个工作表迭代

2 个答案: