[已解决]继续追问：如何批量生成带格式的工作簿

love_liwu

老师，您好，现追加一个问题：
假设现在工作簿有7个工作表，除了sheet1和顾客信息表外，还有其他5个工作表（DATA、代码表：深度隐藏，其他显示），现在我想批量生成除sheet1外其他工作表都有的工作簿（DATA、代码表继续深度隐藏），请问以下代码（感谢grf1973老师提供的代码）如何修改？

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


demo.zip (26.78 KB, 下载次数: 2)

2015-7-23 08:56 上传

点击文件名下载附件


恳请老师的解答！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-7-23 11:00

得另建一个工作表，用于操作。代码如下：

1. Sub tt()
   
2.     Dim wb As Workbook
   
3.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\顾客信息.xls")
   
4.     Application.DisplayAlerts = False
   
5.     Application.ScreenUpdating = False
   
6.     arr = wb.Sheets(1).[a1].CurrentRegion
   
7.     For i = 2 To UBound(arr)
   
8.         If i = 2 Then wb.Worksheets(1).Delete
   
9.         wb.SaveAs ThisWorkbook.Path & "" & arr(i, 1) & ".xls"
   
10.         With ActiveWorkbook.Sheets(1)
    
11.             .[c4] = arr(i, 1)
    
12.             .[g4] = arr(i, 2)
    
13.             .[c5] = arr(i, 3)
    
14.             .[g5] = arr(i, 4)
    
15.             .[c6] = arr(i, 5)
    
16.             .[g6] = arr(i, 6)
    
17.             .[c13].Resize(1, 4) = Array(arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10))
    
18.         End With
    
19.         ActiveWorkbook.Save
    
20.         Set wb = ActiveWorkbook
    
21.     Next
    
22.     wb.Close
    
23.     Application.DisplayAlerts = True
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

得另建一个工作表，用于操作。代码如下：

1. Sub tt()
   
2.     Dim wb As Workbook
   
3.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\顾客信息.xls")
   
4.     Application.DisplayAlerts = False
   
5.     Application.ScreenUpdating = False
   
6.     arr = wb.Sheets(1).[a1].CurrentRegion
   
7.     For i = 2 To UBound(arr)
   
8.         If i = 2 Then wb.Worksheets(1).Delete
   
9.         wb.SaveAs ThisWorkbook.Path & "" & arr(i, 1) & ".xls"
   
10.         With ActiveWorkbook.Sheets(1)
    
11.             .[c4] = arr(i, 1)
    
12.             .[g4] = arr(i, 2)
    
13.             .[c5] = arr(i, 3)
    
14.             .[g5] = arr(i, 4)
    
15.             .[c6] = arr(i, 5)
    
16.             .[g6] = arr(i, 6)
    
17.             .[c13].Resize(1, 4) = Array(arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10))
    
18.         End With
    
19.         ActiveWorkbook.Save
    
20.         Set wb = ActiveWorkbook
    
21.     Next
    
22.     wb.Close
    
23.     Application.DisplayAlerts = True
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

love_liwu

grf1973 发表于 2015-7-23 11:00
得另建一个工作表，用于操作。代码如下：

谢谢老师，如果顾客信息工作簿每一个工作表都有保护密码怎么办？好像提示错误。

运行时错误 1004

grf1973

只要样表没保护就行了。