我在Sheet2中有一个列表(例如A:A)。我想将每个项目复制到Sheet1的单元格中(例如“ A1”),另存为新工作簿,然后继续浏览sheet2中的列表。列表完成后,我需要循环结束。
任何帮助将不胜感激。
谢谢。
答案 0 :(得分:0)
这将使您入门。这不是完美的
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