VBA：将数据从 Excel 行传输到另一个工作簿中的特定单元格，另存为并循环到下一行。

Question

一位客户要求我们通过将数据从 excel 行复制并粘贴到他们指定的模板（也在 excel 中）来生成报告。这对于他们提供的提取数据中的所有条目都是必需的。

所以循环是：

1. 打开工作簿 B 的空白副本
2. 从工作簿 A（代码所在的位置）复制数据
3. 将数据粘贴到工作簿 B 中的指定单元格中
4. 使用单元格 A1 作为文件名保存工作簿 B
5. 关闭工作簿 B
6. 进入工作簿 A 的下一行并重复。

这是我目前写的，显然它甚至没有接近我想要它做的，但到目前为止我所做的研究只是让我更加困惑！

（请原谅中间的“工作表名称”等，我曾尝试在此处使用我以前的代码部分，但我意识到它不会工作到一半）

Sub Transfer()

Dim x As Workbook
Dim y As Workbook
Dim strpath As String
Dim strfolderpath As String
Dim z As Integer
Application.ScreenUpdating = False

'## Open both workbooks first:
Set x = Workbooks.Open("c:\desktop\client data\export.xls")
Set y = Workbooks.Open("c:\desktop\client data\output template.xls")

' Set numrows = number of rows of data.
  NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
  ' Select cell a1.
  Range("A1").Select
  ' Set loop
  For z = 1 To NumRows

                    'copy data from x:
                    x.Sheets("name of copying sheet").Range("E6").Copy

                    'paste to y worksheet:
                    y.Sheets("sheetname").Range("C1").PasteSpecial

                    'copy data from x:
                    x.Sheets("name of copying sheet").Range("E7").Copy

                    'paste to y worksheet:
                    y.Sheets("sheetname").Range("F7").PasteSpecial

                    'copy data from x:
                    x.Sheets("name of copying sheet").Range("E8").Copy

                    'paste to y worksheet:
                    y.Sheets("sheetname").Range("A1").PasteSpecial

                    'save new worksheet

                        ' Save filename based on cell value

                             strfolderpath = "C:\"
                             strpath = strfolderpath & _
                                y.Sheets("").Range("A1").Value & " Report" & ".xlsx"

                            ActiveWorkbook.SaveAs Filename:=strpath

        ' Selects cell down 1 row.
             ActiveCell.Offset(1, 0).Select
    Next

Application.ScreenUpdating = True


End Sub

我期待在您的帮助下扩展我的 VBA 知识。

问候，

马修

Answer 1

我只是稍微修改一下你的原始代码：

Sub Transfer()

Dim x As Workbook
Dim y As Workbook
Dim strpath As String
Dim strfolderpath As String
Dim z As Integer
Application.ScreenUpdating = False

'## Open both workbooks first:
Set x = Workbooks.Open("c:\desktop\client data\export.xls")
Set y = Workbooks.Open("c:\desktop\client data\output template.xls")

x.Sheets("name of copying sheet").activate

' Set numrows = number of rows of data.
  NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
  ' Select cell a1.
  Range("A1").Select
  ' Set loop
  For z = 1 To NumRows

                    'copy data from x:
                    x.Sheets("name of copying sheet").Cells(z,5).Copy 'E6

                    'paste to y worksheet:
                    y.Sheets("sheetname").Range("C1").PasteSpecial

                    'copy data from x:
                    x.Sheets("name of copying sheet").Cells(z+1,5).Copy 'E7

                    'paste to y worksheet:
                    y.Sheets("sheetname").Range("F7").PasteSpecial

                    'copy data from x:
                    x.Sheets("name of copying sheet").Cells(z+2,5).Copy 'E8

                    'paste to y worksheet:
                    y.Sheets("sheetname").Range("A1").PasteSpecial

                    'save new worksheet

                        ' Save filename based on cell value

                             strfolderpath = "C:\"
                             strpath = strfolderpath & _
                                y.Sheets("").Range("A1").Value & " Report" & ".xlsx"

                            ActiveWorkbook.SaveAs Filename:=strpath

        ' Selects cell down 1 row.
             'ActiveCell.Offset(1, 0).Select
         z = z+2
    Next

Application.ScreenUpdating = True


End Sub

Answer 2

根据您的 cmets，这可能会起作用。 您需要调整工作表名称和值来自的单元格（行、列）。

注意，它尚未经过测试。

Sub Transfer()

  Dim sourceDataWb As Workbook
  Dim destinationDataWb As Workbook
  Dim strpath As String
  Dim strfolderpath As String
  Dim numberOfRows As Long, z As Long

  On Error GoTo error_catch

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False

  '## Open both workbooks first:
  Set sourceDataWb = ActiveWorkbook

  numberOfRows = sourceDataWb.Range("A1", Range("A1").End(xlDown)).Rows.Count

  For z = 1 To numberOfRows
    ' OPEN
    Set destinationDataWb = Workbooks.Open("c:\desktop\client data\output template.xls")
    ' COPY AS NECESSARY
    destinationDataWb.Sheets("sheetname").Cells(z, 1).Value = sourceDataWb.Sheets("sheetname").Cells(z, 1).Value
    ' CREATE THE PATH
    strpath = "C:\" & destinationDataWb.Sheets("sheetname").Range("A1").Value & " Report" & ".xlsx"
    ' SAVE
    destinationDataWb.SaveAs Filename:=strpath
    destinationDataWb.close
    'REPEAT
  Next

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  Exit Sub

error_catch:
  MsgBox "Error: " & Err.Description
  Err.Clear
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub