VBA - 循环遍历范围，复制到第二张纸，另存为，重复

Question

我在Sheet2中有一个列表(例如A：A(。 我想将每个项目复制到 Sheet1 中的单元格(例如"A1"(，另存为新工作簿并继续浏览 sheet2 中的列表。我需要在列表完成后结束循环。

任何帮助将不胜感激。

提前谢谢。

Answer 1

这将帮助你开始。它并不完美

Option Explicit
Sub createWorkbooks()
Dim r As Range
Dim i As Integer
Dim lastRow As Integer
Dim workbookName As String
Dim wb As Workbook
Dim ws As Worksheet
Application.DisplayAlerts = False       'Overwrite workbooks without alerts
lastRow = findLastRow("Sheet2", "A:A")  'Get last row of target sheet
For i = 1 To lastRow
On Error Resume Next
ActiveWorkbook.Sheets("Sheet1").Delete  'Remove possible Sheet 1
On Error GoTo 0
'*
'* Create a worksheet template
'*
Set ws = ThisWorkbook.Sheets.Add
ws.Name = "Sheet1"
Set r = Range("Sheet2!A" & i)
ws.Range("A1").Value = r.Value      'Copy source cell value to template
workbookName = r.Value & ".xlsx"    'Set workbook name
'*
'* Create a new workbook
'*
Set wb = Workbooks.Add
'*
'* Copy out newly created template to it
'*
ws.Copy Before:=wb.Sheets(1)
wb.SaveAs workbookName
wb.Close False
Next i
ActiveWorkbook.Sheets("Sheet1").Delete 'Remove last template
Application.DisplayAlerts = True
End Sub
'*******************************************************
'* Find last used row in a certain sheet
'*
Function findLastRow(Sheetname As String, ColumnName As String) As Integer
Dim lastRow As Integer
Dim r As Range
Dim ws As Worksheet
Set ws = Worksheets(Sheetname)
lastRow = ws.UsedRange.Rows.Count
'*
'* Search backwards till we find a cell that is not empty
'*
Set r = ws.Range(ColumnName).Rows(lastRow)
While IsEmpty(r)
Set r = r.Offset(-1, 0)
Wend
lastRow = r.Row
Set ws = Nothing
findLastRow = lastRow
End Function