Excel：自動複製工作簿和基於列表

VBA（總noob）很新，努力奮鬥，我一直在論壇的各個部分拆分公式的一部分，以獲得我需要的東西，現在我卡住了。Excel：自動複製工作簿和基於列表

基本上我有一個工作簿，我需要說的工作簿重複很多次，它創建一個從這裏列表中保存的名字是我迄今爲止

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」的工作表，我怎樣才能將它們寫入到工作簿中創建的。

預先感謝你們美好的人。

亞歷

來源

2015-10-16 Rojas

因此，總結一下，您希望您的代碼將工作表保存爲每張工作表的單獨工作簿？ – Calum

@Calum現在還沒有，如果我將其他工作表添加到原始工作簿中，它不會將它們添加到工作簿中，此時它只會添加到我的「模板」和「數據」選項卡中，如果我要添加更多選項卡即「data2」寫入：設置sh3 =表（「Data2」）'編輯表名稱這不起作用，如果有意義的話。對不起，如果它看起來模糊。 – Rojas

如果這就是所有你想要的然後保持與'設置SH3 =表（「數據2」）'然後'sh2.Copy後：= wb.Sheets（1）'下面添加'sh3.Copy後：= wb.Sheets（1 ）'，併爲每張紙做同樣的事情。 – Calum

我想這將是一個比你最初的版本更高效，更容易編輯：

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

來源

2015-10-16 12:03:55 R3uK

非常感謝你的工作@R3uK！ – Rojas

很高興能幫到你！由於您剛接觸SO，只是簡單提醒您的基本知識：一旦答案解決了您的問題，請使用上/下投票中的勾號進行驗證。如果您發現任何帖子有用/無用，請記住使用向上/向下投票（一旦您有15點聲望點）！ ;）享受吧！ – R3uK

遲到了幾分鐘。
我會寫下面的代碼。
而不是在代碼中聲明要複製哪些工作表，只需在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

來源

2015-10-16 12:18:15

Excel：自動複製工作簿和基於列表

回答

相關問題