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