Excel：自动复制工作簿并基于列表

Question

对于VBA（总的菜鸟）而言非常陌生并且努力奋斗，我已经从论坛的各个部分中蚕食了一些配方，以获得我需要的东西，现在我被卡住了。

基本上我有一本工作簿，我需要说工作簿多次重复，并且从列表中创建保存名称到目前为止我所拥有的

Sub create()
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Range
Set sh1 = Sheets("List") 'Edit sheet name
Set sh2 = Sheets("Data") 'Edit sheet name
lr = sh1.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = sh1.Range("A1:A" & lr)

For Each c In rng
    Sheets("Template").Copy 'Edit sheet name
    Set wb = ActiveWorkbook
    wb.Sheets(1).Range("A1") = c.Value
    sh2.Copy After:=wb.Sheets(1)
    wb.SaveAs c.Value & ".xlsx"
    wb.Close False
Next
End Sub

所以列表显然是我的文件名称列表，它运行良好，但是工作簿除了＆＃34; Data＆＃34;之外还有更多的工作表。和＆＃34;模板＆＃34;所以，如果我有其他名为＆＃34; Data2＆＃34;和＆＃34; Data3＆＃34;例如，我如何编写它们以便复制到创建的工作簿中。

提前感谢你们精彩的人。

亚历

Answer 1

我猜这个版本比初始版本更有效，更容易编辑：

Sub create()
Dim WbSrc As Workbook, _
    WbDest As Workbook, _
    SheetToExport As String, _
    sh1 As Worksheet, _
    lr As Long, _
    rng As Range, _
    A() As String


Set WbSrc = ThisWorkbook
Set sh1 = WbSrc.Sheets("List") '----Edit sheet name
lr = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
Set rng = sh1.Range("A1:A" & lr)

'----Add sheet's names here separated with /
'----They will be exported in the same order
SheetToExport = "Template/Data/Data2"
A = Split(SheetToExport, "/")

'----Make a new workbook with all the sheet you want to export
WbSrc.Sheets(A(0)).Copy
Set WbDest = ActiveWorkbook
For i = LBound(A) + 1 To UBound(A)
    WbSrc.Sheets(A(i)).Copy After:=WbDest.Sheets(WbDest.Sheets.Count)
Next i

'----Now that the base is good, change value in A1 and SaveAs
For Each c In rng
    WbDest.Sheets(1).Range("A1") = c.Value
    Set WbDest = WbDest.SaveAs(c.Value & ".xlsx")
Next c

WbDest.Close False

End Sub

Answer 2

迟到几分钟 我会像下面的代码一样写 如果要复制工作表，只需在列A中添加工作表名称，而不是在列B中添加工作表名称，然后在另一列中添加要使用的文件名。

可以使用公式来计算命名范围的长度 - 例如 = Sheet1！$ A $ 1：INDEX（Sheet1！$ A：$ A，COUNTA（Sheet1！$ A：$ A））< / strong>获取sheet1列A中的所有值。

Public Sub Create()

    Dim wrkBk As Workbook
    Dim wrkSht As Worksheet
    Dim rngFiles As Range
    Dim rngSheets As Range
    Dim c As Range
    Dim d As Range

    'Named ranges in your workbook.
    Set rngFiles = Range("FileNames")
    Set rngSheets = Range("SheetsToCopy")

    'Each file name
    For Each d In rngFiles
        Set wrkBk = Nothing

        'Check if each sheet is needed - 1 column to right of
        'sheet name states TRUE if you want the sheet copied.
        For Each c In rngSheets
            If c.Offset(, 1) = True Then

                If wrkBk Is Nothing Then
                    'Create a new workbook if one hasn't been created.
                    ThisWorkbook.Worksheets(c.Value).Copy
                    Set wrkBk = ActiveWorkbook
                Else
                    'If workbook has been created then copy sheets to it.
                    ThisWorkbook.Worksheets(c.Value).Copy _
                        After:=wrkBk.Sheets(1)
                End If
            End If
        Next c
        'Save the file and close it.
        wrkBk.SaveAs d.Value & ".xlsx", FileFormat:=xlWorkbookDefault
        wrkBk.Close
    Next d

End Sub