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