VB宏來創建新的工作簿，並從原材

Question

我有工作作爲宏如下預填充新的工作簿：

我有中有四個選項卡， *指數的工作簿 - 包含列表建築信息（總共5列從A的整理E開始，有些月份可能有3行，其他月份可能有100行 *模板 - 具有基本建築信息的模板頁面 *數據 - 清單 * B2 - 另一個清單

我需要的宏是做一個新的工作簿，其中包含工作表「模板」「數據」和「B2」

新的工作簿需要按照包含在A列的索引表

然後我需要位於索引選項卡的列表複製到細胞F2，F3，F4，F5在建築物的名稱被命名爲，F6 F5爲每一個新的工作簿模板標籤（每個頭）

下面就爲它工作，但目前只prefills在新的工作簿中單元格F2模板工作表上

Sub temp() 
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Range 
Set sh1 = Sheets("Index") 'Edit sheet name 
Set sh2 = Sheets("B2") 'Edit sheet name 
Set sh3 = Sheets("Data") 'Edit sheet name 
lr = sh1.Cells(Rows.Count, "A").End(xlUp).Row 
Set rng = sh1.Range("A2:A" & lr) 
    For Each c In rng 
     Sheets("Template").Copy 'Edit sheet name 
     Set wb = ActiveWorkbook 
     wb.Sheets(1).Range("F2") = c.Value 
     sh2.Copy After:=wb.Sheets(1) 
     sh3.Copy After:=wb.Sheets(2) 
     wb.SaveAs c.Value & ".xlsx" 
     wb.Close False 
    Next 
End Sub 

感謝代碼堆...我確定我有9這個工作剛結束的0％觸及

Answer 1

試試這個

Sub temp() 
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Range, x as long 
Set sh1 = Sheets("Index") 'Edit sheet name 
Set sh2 = Sheets("B2") 'Edit sheet name 
Set sh3 = Sheets("Data") 'Edit sheet name 
lr = sh1.Cells(Rows.Count, "A").End(xlUp).Row 
Set rng = sh1.Range("A2:A" & lr) 
x = 2 
For Each c In rng 
    Sheets("Template").Copy 'Edit sheet name 
    Set wb = ActiveWorkbook 
    wb.Sheets(1).Range("F" & x) = c.Value 
    x = x + 1 
    sh2.Copy After:=wb.Sheets(1) 
    sh3.Copy After:=wb.Sheets(2) 
    wb.SaveAs c.Value & ".xlsx" 
    wb.Close False 
Next 
End Sub