[已解决]新新手求助，导出新表另存为问题 ？？？

daxindianqi

有段程序不会写，求助大家：在保有现有功能不变的情况下实现“另存为”时发现有相同文件名，显示WINDOWS标准的“另存为”窗口，在窗口下部的文件名显示为本程序自动生成的文件名以方便修改版本，例如将“V1.00”改为“V2.00”等等！

1. 
   
2. 
   
3. Private Sub CommandButton1_Click()
   
4. On Error Resume Next
   
5. If Range("a1") = "" Or Range("f3") = "" Or Range("h3") = "" Or Range("b7") = "" Or Range("b6") = "" Then
   
6. Unload UserForm4
   
7. MsgBox "请将公司、项目、业务员、报价员信息填写完全再保存 !"
   
8. 
   
9. Else
   
10. 
    
11.     Dim fso As Scripting.FileSystemObject
    
12.     Dim myFolder As String
    
13.     Application.ScreenUpdating = False
    
14.     lr = 30
    
15.     lr1 = 50
    
16.     With ThisWorkbook
    
17.    
    
18.         Workbooks.Add (1)
    
19.         .Sheets(2).Range("A:I").Copy
    
20.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
    
21.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteFormats
    
22.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    
23.         ActiveWorkbook.Sheets.Add
    
24.         .Sheets(1).Range("A:H").Copy
    
25.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
    
26.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteFormats
    
27.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    
28.         
    
29.     End With
    
30.    
    
31.     myFolder = "d:\报价文件"
    
32.     Set fso = New Scripting.FileSystemObject
    
33.     If fso.FolderExists(myFolder) Then
    
34.         Call 导出数据
    
35.     Else
    
36.         fso.CreateFolder myFolder
    
37.         Call 导出数据
    
38.     End If
    
39.     Set fso = Nothing
    
40.     Application.ScreenUpdating = True
    
41.     MsgBox "数据已被导出,保存在D:\报价文件\...", 48, "导出提示"
    
42.     Unload UserForm4
    
43.     End If
    
44. End Sub
    
45. Sub 导出数据()
    
46. 
    
47.     ''需要改变程序，实现在发现有相同文件名时，显示WINDOWS标准的“另存为”窗口，在窗口下部的文件名显示为本程序自动生成的文件名以方便修改版本，例如V1.00、V2.00等等！
    
48.    
    
49.     Application.DisplayAlerts = False
    
50.     ActiveWorkbook.SaveAs MyPath & "d:\报价文件\ MSGM(JS)" & "_" & Range("B2") & "_TO " & Range("B6") & "." & Range("B7") & "." & Range("G6") & "(" & "报价" & ")" & "_ FROM." & Range("F3") & "(" & Range("H3") & ") V1.00" & ".xlsx"
    
51.     ActiveWorkbook.Close
    
52.     Application.DisplayAlerts = True
    
53.     Application.ScreenUpdating = True
    
54. End Sub
    
55. 
    
56. Private Sub CommandButton2_Click()
    
57. Unload UserForm4
    
58. End Sub
    
59. 
    
60. Private Sub Frame1_Click()
    
61. 
    
62. End Sub
    

复制代码

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-10 12:07

1. Sub 导出数据()
   
2.     Dim MyName$
   
3.     Dim wb As Workbook
   
4.     ''需要改变程序，实现在发现有相同文件名时，显示WINDOWS标准的“另存为”窗口，在窗口下部的文件名显示为本程序自动生成的文件名以方便修改版本，例如V1.00、V2.00等等！
   
5.     Application.DisplayAlerts = False
   
6.     MyName = "d:\报价文件\ MSGM(JS)" & "_" & Range("B2") & "_TO " & Range("B6") & "." & Range("B7") & "." & Range("G6") & "(" & "报价" & ")" & "_ FROM." & Range("F3") & "(" & Range("H3") & ") V1.00" & ".xlsx"
   
7.     If Dir(MyName) = vbNullString Then
   
8.         ActiveWorkbook.SaveAs MyPath & MyName
   
9.         
   
10.     Else
    
11.         Filename = Application.GetSaveAsFilename(MyName)
    
12.         Set wb = ActiveWorkbook
    
13.         wb.SaveAs Filename
    
14.     End If
    
15.     ActiveWorkbook.Close
    
16.     Application.DisplayAlerts = True
    
17.     Application.ScreenUpdating = True
    
18. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

1. Sub 导出数据()
   
2.     Dim MyName$
   
3.     Dim wb As Workbook
   
4.     ''需要改变程序，实现在发现有相同文件名时，显示WINDOWS标准的“另存为”窗口，在窗口下部的文件名显示为本程序自动生成的文件名以方便修改版本，例如V1.00、V2.00等等！
   
5.     Application.DisplayAlerts = False
   
6.     MyName = "d:\报价文件\ MSGM(JS)" & "_" & Range("B2") & "_TO " & Range("B6") & "." & Range("B7") & "." & Range("G6") & "(" & "报价" & ")" & "_ FROM." & Range("F3") & "(" & Range("H3") & ") V1.00" & ".xlsx"
   
7.     If Dir(MyName) = vbNullString Then
   
8.         ActiveWorkbook.SaveAs MyPath & MyName
   
9.         
   
10.     Else
    
11.         Filename = Application.GetSaveAsFilename(MyName)
    
12.         Set wb = ActiveWorkbook
    
13.         wb.SaveAs Filename
    
14.     End If
    
15.     ActiveWorkbook.Close
    
16.     Application.DisplayAlerts = True
    
17.     Application.ScreenUpdating = True
    
18. End Sub

复制代码

daxindianqi

老司机带带我 发表于 2016-6-10 12:07

谢谢你，学习了，完全符合我自己的想法！