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

相当新的VBA（总noob）和努力奋斗，我一直在争论的各个部分的论坛，以获得我所需要的东西，现在我卡住了。

基本上我有一个工作簿，我需要说工作簿多次复制，并从列表中创build保存名称这里是我到目前为止

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 

所以列表显然是我的文件名称列表，它运作良好，但工作簿有更多的工作表以外的“数据”和“模板”，所以如果我有其他工作表命名为“数据2”和“数据3”例如我怎么能写入它们也被复制到创build的工作簿中。

提前谢谢你，精彩的人。

亚历克斯

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））来获取列A中的所有值sheet1。

 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