[已解决]重新求助：求高手帮助当前工作表另存为工作簿

BL123123

[size=13.913043975830078px]重新求助：求高手帮助当前工作表另存为工作簿
[size=13.913043975830078px]一、勾选B2点击“保存”按钮，当前工作表另存为新的工作簿，条件：
[size=13.913043975830078px]1、新工作簿名称为A2+B2单元格内容，中间最好添加“：或--”连接符号，如：【考核：单位1 】或【考核--单位1】；
[size=13.913043975830078px]2、新工作簿工作表不带公式，数据为文本格式，并去除按钮。
[size=13.913043975830078px]3、新工作簿保存在当前文件夹下。
[size=13.913043975830078px]二、B2下拉菜单，数量较多，希望通过点击“全部保存”按钮，B2下拉菜单中的所有单位全部另存为新工作簿，新工作簿的要求与上面相同。
[size=13.913043975830078px]原求助时考虑不周样本中没带宏及公式，所以在样本中测试成功，但正式操作结果带公式且出现乱码，再求高手出手帮助，谢谢
[size=13.913043975830078px]详见附件及截屏

最佳答案

月排行榜 / 总排行榜

su45

2016-10-15 09:32

1. Sub suaa()
   
2. Application.ScreenUpdating = False
   
3. Application.DisplayAlerts = False
   
4. pa = ThisWorkbook.Path & ""
   
5. fnam = [A2] & "-" & [B2]
   
6. If Dir(pa & fnam & ".xls*") <> "" Then
   
7.     x = MsgBox("此文件已存在，是否删除？", 4)
   
8.     If x = 7 Then Exit Sub
   
9.     Kill pa & fnam & ".xls*"
   
10. End If
    
11. With Workbooks.Add
    
12.     Cells.Copy .Sheets(1).Cells
    
13.     .Sheets(1).Cells.PasteSpecial Paste:=xlPasteValues
    
14.     For Each sp In .Sheets(1).Shapes
    
15.         sp.Delete
    
16.     Next
    
17.     .SaveAs pa & fnam
    
18.     .Close
    
19. End With
    
20. Application.DisplayAlerts = True
    
21. End Sub
    
22. Sub suab()
    
23. Application.ScreenUpdating = False
    
24. Application.DisplayAlerts = False
    
25. pa = ThisWorkbook.Path & ""
    
26. dw = Sheet1.Range("考核单位")
    
27. For i = 1 To UBound(dw)
    
28.     [B2] = dw(i, 1)
    
29.     fnam = [A2] & "-" & [B2]
    
30.     If Dir(pa & fnam & ".xls*") <> "" Then Kill pa & fnam & ".xls*"
    
31.     With Workbooks.Add
    
32.         Cells.Copy .Sheets(1).Cells
    
33.         .Sheets(1).Cells.PasteSpecial Paste:=xlPasteValues
    
34.         For Each sp In .Sheets(1).Shapes
    
35.             sp.Delete
    
36.         Next
    
37.         .SaveAs pa & fnam
    
38.         .Close
    
39.     End With
    
40. Next
    
41. Application.DisplayAlerts = True
    
42. End Sub

复制代码

跳转到最佳答案楼层

BL123123

[size=13.913043975830078px]不知怎么回事，出现了乱码，应该是：
[size=13.913043975830078px]

重新求助：求高手帮助当前工作表另存为工作簿
[size=13.913043975830078px]一、勾选B2点击“保存”按钮，当前工作表另存为新的工作簿，条件：
[size=13.913043975830078px]1、新工作簿名称为A2+B2单元格内容，中间最好添加“：或--”连接符号，如：【考核：单位1 】或【考核--单位1】；
[size=13.913043975830078px]2、新工作簿工作表不带公式，数据为文本格式，并去除按钮。
[size=13.913043975830078px]3、新工作簿保存在当前文件夹下。
[size=13.913043975830078px]二、B2下拉菜单，数量较多，希望通过点击“全部保存”按钮，B2下拉菜单中的所有单位全部另存为新工作簿，新工作簿的要求与上面相同。
[size=13.913043975830078px]原求助时考虑不周样本中没带宏及公式，所以在样本中测试成功，但正式操作结果带公式且出现乱码，再求高手出手帮助，谢谢
[size=13.913043975830078px]详见附件及截屏

BL123123

重新求助：求高手帮助当前工作表另存为工作簿
一、勾选B2点击“保存”按钮，当前工作表另存为新的工作簿，条件：
1、新工作簿名称为A2+B2单元格内容，中间最好添加“：或--”连接符号，如：【考核：单位1 】或【考核--单位1】；
2、新工作簿工作表不带公式，数据为文本格式，并去除按钮。
3、新工作簿保存在当前文件夹下。
二、B2下拉菜单，数量较多，希望通过点击“全部保存”按钮，B2下拉菜单中的所有单位全部另存为新工作簿，新工作簿的要求与上面相同。
原求助时考虑不周样本中没带宏及公式，所以在样本中测试成功，但正式操作结果带公式且出现乱码，再求高手出手帮助，谢谢

su45

考核表.zip (73.55 KB, 下载次数: 33)

2016-10-14 10:15 上传

点击文件名下载附件

BL123123

su45 发表于 2016-10-14 10:15

非常感谢高手的解答，第一个问题完美解决了，第二个问题：B2单元格下拉菜单单位全部另存为还需请您帮忙看看，再次感谢

su45

改下：

dw = Sheet2.Range("考核单位")

BL123123

su45 发表于 2016-10-14 11:44
改下：

dw = Sheet2.Range("考核单位")

非常感谢高手的帮助，代码修改了下：
Sub suab()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
pa = ThisWorkbook.Path & "\"
dw = Sheet2.Range("考核单位")
For i = 1 To UBound(dw)
    [b2] = dw(i, 1)
    fnam = [A2] & "-" & [b2]
    If Dir(pa & fnam & ".xls*") <> "" Then Kill pa & fnam & ".xls*"
    With Workbooks.Add
        Cells.Copy .Sheets(1).Cells
        .Sheets(1).Cells.PasteSpecial Paste:=xlPasteValues
        For Each sp In .Sheets(1).Shapes
            sp.Delete
        Next
        .SaveAs pa & fnam
        .Close
    End With
Next
Application.DisplayAlerts = True
End Sub

原来所有的C2单元格都改成了B2 可能我的参数修改有问题，按钮指定宏后运行报错， X 400  恳请您在帮忙看下问题出在了那里，谢谢

BL123123

su45 发表于 2016-10-14 11:44
改下：

dw = Sheet2.Range("考核单位")

您好，我又仔细的比对了一下，  dw = Sheet2.Range("单位")   原来我是在 sheet2 C列给下拉菜单定义的名称  ”单位“
最后发帖的表，下拉菜单由C2改为了B2，下拉菜单定义的名称在【总表49项】工作表中，定义的名称为："考核单位"
dw = Sheet2.Range("单位")       [C2] = dw(i, 1)     把”单位“改成”考核单位“ 【C2]改为【B2] 不知是否还应修改：
sheet2   或  dw(i, 1)   我是新手，第一个问题您完美解决了，第二个问题只是我参数修改的
有问题，恳请高手帮忙修改下参数。   谢谢

su45

1. Sub suaa()
   
2. Application.ScreenUpdating = False
   
3. Application.DisplayAlerts = False
   
4. pa = ThisWorkbook.Path & ""
   
5. fnam = [A2] & "-" & [B2]
   
6. If Dir(pa & fnam & ".xls*") <> "" Then
   
7.     x = MsgBox("此文件已存在，是否删除？", 4)
   
8.     If x = 7 Then Exit Sub
   
9.     Kill pa & fnam & ".xls*"
   
10. End If
    
11. With Workbooks.Add
    
12.     Cells.Copy .Sheets(1).Cells
    
13.     .Sheets(1).Cells.PasteSpecial Paste:=xlPasteValues
    
14.     For Each sp In .Sheets(1).Shapes
    
15.         sp.Delete
    
16.     Next
    
17.     .SaveAs pa & fnam
    
18.     .Close
    
19. End With
    
20. Application.DisplayAlerts = True
    
21. End Sub
    
22. Sub suab()
    
23. Application.ScreenUpdating = False
    
24. Application.DisplayAlerts = False
    
25. pa = ThisWorkbook.Path & ""
    
26. dw = Sheet1.Range("考核单位")
    
27. For i = 1 To UBound(dw)
    
28.     [B2] = dw(i, 1)
    
29.     fnam = [A2] & "-" & [B2]
    
30.     If Dir(pa & fnam & ".xls*") <> "" Then Kill pa & fnam & ".xls*"
    
31.     With Workbooks.Add
    
32.         Cells.Copy .Sheets(1).Cells
    
33.         .Sheets(1).Cells.PasteSpecial Paste:=xlPasteValues
    
34.         For Each sp In .Sheets(1).Shapes
    
35.             sp.Delete
    
36.         Next
    
37.         .SaveAs pa & fnam
    
38.         .Close
    
39.     End With
    
40. Next
    
41. Application.DisplayAlerts = True
    
42. End Sub

复制代码

BL123123

su45 发表于 2016-10-15 09:32

最佳答案诞生了，非常感谢您的帮助，我是新手，还想问一下，
  dw = Sheet1.Range("考核单位")  
假如我定义名称放在同工作簿的"考核指标"工作表中
名称定义为"考核单位1"    dw = Sheet1.Range("考核单位1")  
Sheet1 还用修改吗？ 谢谢