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

love_liwu

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

PS：如果该工作簿均设保护密码，代码是否一样呢？

Sub tt()
    Dim wb As Workbook
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\顾客信息.xls")
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    arr = wb.Sheets(1).[a1].CurrentRegion
    For i = 2 To UBound(arr)
        If i = 2 Then wb.Worksheets(1).Delete
        wb.SaveAs ThisWorkbook.Path & "\" & arr(i, 1) & ".xls"
        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.Save
        Set wb = ActiveWorkbook
    Next
    wb.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

demo.zip (30.56 KB, 下载次数: 7)

2015-7-23 12:39 上传

点击文件名下载附件
恳请老师指导！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-7-24 10:55

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.             .Unprotect "123"
    
12.             .[c4] = arr(i, 1)
    
13.             .[g4] = arr(i, 2)
    
14.             .[c5] = arr(i, 3)
    
15.             .[g5] = arr(i, 4)
    
16.             .[c6] = arr(i, 5)
    
17.             .[g6] = arr(i, 6)
    
18.             .[c13].Resize(1, 4) = Array(arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10))
    
19.             .Protect "123"
    
20.         End With
    
21.         ActiveWorkbook.Save
    
22.         Set wb = ActiveWorkbook
    
23.     Next
    
24.     wb.Close
    
25.     Application.DisplayAlerts = True
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    

复制代码

跳转到最佳答案楼层

thinkersky

试试这份行不行

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.             .Unprotect "123"
    
12.             .[c4] = arr(i, 1)
    
13.             .[g4] = arr(i, 2)
    
14.             .[c5] = arr(i, 3)
    
15.             .[g5] = arr(i, 4)
    
16.             .[c6] = arr(i, 5)
    
17.             .[g6] = arr(i, 6)
    
18.             .[c13].Resize(1, 4) = Array(arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10))
    
19.             .Protect "123"
    
20.         End With
    
21.         ActiveWorkbook.Save
    
22.         Set wb = ActiveWorkbook
    
23.     Next
    
24.     wb.Close
    
25.     Application.DisplayAlerts = True
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    

复制代码

grf1973

注意第11和19句，是解除（加上）保护，密码123

love_liwu

thinkersky 发表于 2015-7-24 10:36
试试这份行不行

谢谢老师，您好像破解了我的保护密码了。我的意思是不破坏密码让VBA代码能正常运行。

再次感谢老师。

love_liwu

grf1973 发表于 2015-7-24 10:56
注意第11和19句，是解除（加上）保护，密码123

老师，您怎么知道我的密码的？怎么查看呢？太神奇了。

grf1973

猜的。。。。。。

love_liwu

grf1973 发表于 2015-7-27 09:32
猜的。。。。。。