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:desktopclient dataexport.xls")
Set y = Workbooks.Open("c:desktopclient dataoutput 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 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:desktopclient dataoutput 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

Answer 2

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

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:desktopclient dataexport.xls")
Set y = Workbooks.Open("c:desktopclient dataoutput 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