[已解决]如何批量生成带格式的工作簿

love_liwu

在此首先非常感谢刘苏版主对我耐心的指导，虽然代码还不完善，我还在继续研究和询问中。

感谢grf1973 老师的完美解答，谢谢！

老师，您好，我想实现以下目标：
文件内有顾客信息登记表和顾客信息（内容均为化名），要求根据顾客名称自动生成跟顾客信息登记表一摸一样的工作簿。
请问老师，如何用VBA批量生成跟顾客信息登记表一样格式的工作簿？（以“顾客信息登记表”为模板，有多少个顾客就生成多少个工作簿，生成的工作簿格式跟“顾客信息登记表”一摸一样，而且能自动匹配相关信息）

最佳答案

月排行榜 / 总排行榜

grf1973

2015-7-22 11:00

1. Sub tt()
   
2.     Application.DisplayAlerts = False
   
3.     arr = [a1].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         Sheets("顾客信息").Copy
   
6.         With ActiveWorkbook.Sheets(1)
   
7.             .[c4] = arr(i, 1)
   
8.             .[g4] = arr(i, 2)
   
9.             .[c5] = arr(i, 3)
   
10.             .[g5] = arr(i, 4)
    
11.             .[c6] = arr(i, 5)
    
12.             .[g6] = arr(i, 6)
    
13.             .[c13].Resize(1, 4) = Array(arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10))
    
14.         End With
    
15.         ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & arr(i, 1) & ".xls"
    
16.         ActiveWorkbook.Close
    
17.     Next
    
18.     Application.DisplayAlerts = True
    
19. End Sub
    

复制代码

跳转到最佳答案楼层

刘苏

登记表可以用Word吗  邮件合并最快了

love_liwu

刘苏 发表于 2015-7-21 20:21
登记表可以用Word吗  邮件合并最快了

老师，您好，不能用word。只能用Excel，您能帮我看看吗？

刘苏

怕麻烦。。有兴趣自己学吗？ 我可以帮你找找资料 Q907065070

grf1973

1. Sub tt()
   
2.     Application.DisplayAlerts = False
   
3.     arr = [a1].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         Sheets("顾客信息").Copy
   
6.         With ActiveWorkbook.Sheets(1)
   
7.             .[c4] = arr(i, 1)
   
8.             .[g4] = arr(i, 2)
   
9.             .[c5] = arr(i, 3)
   
10.             .[g5] = arr(i, 4)
    
11.             .[c6] = arr(i, 5)
    
12.             .[g6] = arr(i, 6)
    
13.             .[c13].Resize(1, 4) = Array(arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10))
    
14.         End With
    
15.         ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & arr(i, 1) & ".xls"
    
16.         ActiveWorkbook.Close
    
17.     Next
    
18.     Application.DisplayAlerts = True
    
19. End Sub
    

复制代码

love_liwu

grf1973 发表于 2015-7-22 11:00

谢谢老师，对了，老师，麻烦您帮我看看这个代码：
Sub 宏1()
Dim i As Integer
For i = 2 To Worksheets("Sheet1").Range("A65536").End(xlUp).Row
    Worksheets("顾客信息").Range("C4").Value = Worksheets("Sheet1").Range("A" & i).Value
    Worksheets("顾客信息").Range("G4").Value = Worksheets("Sheet1").Range("B" & i).Value
    Worksheets("顾客信息").Range("C5").Value = Worksheets("Sheet1").Range("C" & i).Value
    Worksheets("顾客信息").Range("G5").Value = Worksheets("Sheet1").Range("D" & i).Value
    Worksheets("顾客信息").Range("C6").Value = Worksheets("Sheet1").Range("E" & i).Value
    Worksheets("顾客信息").Range("G6").Value = Worksheets("Sheet1").Range("F" & i).Value
    Worksheets("顾客信息").Range("C13").Value = Worksheets("Sheet1").Range("G" & i).Value
    Worksheets("顾客信息").Range("D13").Value = Worksheets("Sheet1").Range("H" & i).Value
    Worksheets("顾客信息").Range("E13").Value = Worksheets("Sheet1").Range("I" & i).Value
    Worksheets("顾客信息").Range("F13").Value = Worksheets("Sheet1").Range("J" & i).Value
   
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Worksheets("Sheet1").Range("A" & i) & ".xls" ' 此处插入另存工作表的代码
    i = i + 1
Next i
End Sub


这是版主刘苏 亲历亲为指导我，可是我比较笨，不知道怎么修改。该程序可以运行，但运行结果只有部分。您看，还可以怎么修改。麻烦了。

grf1973

把里面的i=i+1去掉

love_liwu

grf1973 发表于 2015-7-22 11:39
把里面的i=i+1去掉

谢谢老师，可以全部导出了，对了，老师，以上代码我只需要保留“顾客信息”，如何修改？以上代码连同sheet1表和代码、窗体控件都复制过去了。
请问
Application.SheetsInNewWorkbook = 1
这个代码放在哪好？如何让他辨别我要保留的是“顾客信息”这个工作表？

麻烦指导，谢谢！

inntor123

刘苏 发表于 2015-7-21 20:21
登记表可以用Word吗  邮件合并最快了

你好，刘老师！想请教你下上面宏中的  Sheets("顾客信息").Copy这句，如果我要拷贝几个模板该怎么编写？