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

Question

VBA（总noob）很新，努力奋斗，我一直在论坛的各个部分拆分公式的一部分，以获得我需要的东西，现在我卡住了。

基本上我有一个工作簿，我需要说的工作簿重复很多次，它创建一个从这里列表中保存的名字是我迄今为止

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 

所以名单显然是我的名字的列表文件，它工作得很好，但是工作簿有更多的工作表，而不是“数据”和“模板”，所以如果我有其他名为“Data2”和“Data3”的工作表，我怎样才能将它们写入到工作簿中创建的。

预先感谢你们美好的人。

亚历

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列中添加TRUE（如果您希望复制），然后在另一列中添加要使用的文件名称。

可以使用一个公式来计算您的命名范围有多长 - 类似= Sheet1！$ A $ 1：INDEX（Sheet1！$ A：$ A，COUNTA（Sheet1！$ A：$ A））采取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