VBA - цикл по диапазону, копирование на второй лист, сохранение как, повтор

Question

У меня есть список на Листе 2 (например, A: A). Я хочу скопировать каждый элемент в ячейку на Листе 1 (например, «А1»), сохранить как новую книгу и продолжить список в листе 2. Мне нужно, чтобы цикл завершился после того, как список будет завершен.

Любая помощь будет принята с благодарностью.

Заранее спасибо.

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