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