[已解决]将工作表分开并以工作簿保存

乐乐2006201506

1.将附件中的工作表标签用姓名下面单元格（A2）数据命名；
2.将工作表1、2、3、4……分别单独保存在以工作表标签命名的工作簿中，如，第一个工作表名为1，需要将此工作表移动或复制到新的工作簿中，并以1命名来保存工作簿，同时，为工作簿1加密码，密码为职务（岗位）工资下面单元格（B2）数据；
3.附件已上传，希望能尽快得到各位老师的指点，谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2016-4-12 22:59

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. Application.ScreenUpdating = False
   
4. With ThisWorkbook
   
5.     For i = 1 To .Sheets.Count
   
6.         .Sheets(i).Copy
   
7.         ActiveWorkbook.SaveAs Filename:=mypath & .Sheets(i).Name & ".xls"
   
8.         ActiveWorkbook.Password = .Sheets(i).[b2]
   
9.         ActiveWorkbook.Close 1
   
10.     Next
    
11. End With
    
12. Application.ScreenUpdating = True
    
13. End Sub

复制代码

跳转到最佳答案楼层

乐乐2006201506

Sub Macro1()
'
    Sheets("1").Select
    Sheets("1").Copy
    ActiveWorkbook.SaveAs Filename:="C:\Users\YYB\Documents\1.xlsx", FileFormat _
        :=xlOpenXMLWorkbook, CreateBackup:=False
End Sub

乐乐2006201506

这个是实现保存的代码，"C:\Users\YYB\Documents\1.xlsx"中的1需要是动态的，即为工作表A2中的数据。
还有密码也要是B2中的数据，也是动态的。在此先谢谢各位老师了！

乐乐2006201506

如果一步不能到位，也可以分部写，谢谢！

dsmch

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. Application.ScreenUpdating = False
   
4. With ThisWorkbook
   
5.     For i = 1 To .Sheets.Count
   
6.         .Sheets(i).Copy
   
7.         ActiveWorkbook.SaveAs Filename:=mypath & .Sheets(i).Name & ".xls"
   
8.         ActiveWorkbook.Password = .Sheets(i).[b2]
   
9.         ActiveWorkbook.Close 1
   
10.     Next
    
11. End With
    
12. Application.ScreenUpdating = True
    
13. End Sub

复制代码

乐乐2006201506

dsmch 发表于 2016-4-12 22:59

请问生成的文件打开时出现这个提示框，如果点否，直接退出，点是，没有密码，可以直接打开，麻烦老师再帮忙看看，谢谢！

金樽空对月

乐乐2006201506 发表于 2016-4-12 22:41
如果一步不能到位，也可以分部写，谢谢！

代码如下：

1. Sub mysave()
   
2. Application.ScreenUpdating = False
   
3. Dim x
   
4. Dim wb As Workbook
   
5. For x = 1 To Sheets.Count
   
6.     Sheets(x).Copy
   
7.     Set wb = ActiveWorkbook
   
8.     wb.SaveAs "C:\Users\YYB\Documents" & "" & ThisWorkbook.Sheets(x).Name & ".xlsx", Password:=ThisWorkbook.Sheets(x).Range("b2").Text
   
9.     wb.Close True
   
10.     Set wb = Nothing
    
11. Next x
    
12. Sheets(1).Activate
    
13. Application.ScreenUpdating = True
    
14. End Sub
    

复制代码

乐乐2006201506

密码的问题是我自己没有在B2单元格中输入密码，出现这个提示框的原因是文件扩展名的问题，我在B2单元格输入数据并把文件扩展名修改为.xlsx后解决了这两个问题，麻烦能不能实现“工作表标签以姓名下面单元格（A2）数据命名”，谢谢！

dsmch

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. Application.ScreenUpdating = False
   
4. With ThisWorkbook
   
5.     For i = 1 To .Sheets.Count
   
6.         .Sheets(i).Copy
   
7.         ActiveWorkbook.SaveAs Filename:=mypath & .Sheets(i).[a2] & ".xlsx"
   
8.         ActiveWorkbook.Password = .Sheets(i).[b2]
   
9.         ActiveWorkbook.Close 1
   
10.     Next
    
11. End With
    
12. Application.ScreenUpdating = True
    
13. End Sub

复制代码

乐乐2006201506

金樽空对月 发表于 2016-4-12 23:19
代码如下：

谢谢你，希望系统能够不知是有一个最佳答案选项。