[已解决]求助VBA代码， 工作簿文件保存在工作簿目录下文件夹内的代码！！

daxindianqi

各位老师：

这是一段EXCEL VBA 代码，执行后将工作簿按照不同单元格内容组合成的文件名保存到“z:\报价文件”文件夹下，现在我要求文件保存到工作簿本身所在目录下的“报价文件”文件夹内，代码该怎么样写？？？

1. Dim myfilepath As String
   
2. Private Sub CommandButton1_Click()
   
3. Application.DisplayAlerts = False
   
4. If Range("a1") = "" Or Range("f3") = "" Or Range("h3") = "" Or Range("b7") = "" Or Range("b6") = "" Then
   
5.   Unload UserForm4
   
6.   MsgBox "请将公司、项目、业务员、报价员信息填写完全再保存 !"
   
7. Else
   
8. Dim fso As Scripting.FileSystemObject
   
9. Application.ScreenUpdating = False
   
10.     lr = 30
    
11.     lr1 = 50
    
12.     With ThisWorkbook
    
13.         Workbooks.Add (1)
    
14.         .Sheets(2).Range("A:I").Copy
    
15.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
    
16.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteFormats
    
17.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    
18.         ActiveWorkbook.Sheets.Add
    
19.         .Sheets(1).Range("A:H").Copy
    
20.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
    
21.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteFormats
    
22.         ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    
23.     End With
    
24.     myFolder = "z:\报价文件"
    
25.     Set fso = New Scripting.FileSystemObject
    
26.     If fso.FolderExists(myFolder) Then
    
27.         Call 导出数据
    
28.     Else
    
29.         fso.CreateFolder myFolder
    
30.         Call 导出数据
    
31.     End If
    
32.     Set fso = Nothing
    
33.     Application.ScreenUpdating = True
    
34.          MsgBox "数据已被导出, " & myfilepath    '保存在D:\报价文件\...", 48, "导出提示"
    
35.          Unload UserForm4
    
36.     End If
    
37. End Sub
    
38. 
    
39. Sub 导出数据()
    
40.     On Error Resume Next
    
41.     Application.DisplayAlerts = False
    
42.     Call getfilepath
    
43.     ActiveWorkbook.SaveAs myfilepath
    
44.     Application.DisplayAlerts = True
    
45.     Application.ScreenUpdating = True
    
46.     ActiveWorkbook.Open
    
47. End Sub
    
48. Private Sub CommandButton2_Click()
    
49. On Error Resume Next
    
50. Unload UserForm4
    
51. End Sub
    
52. 
    
53. Private Sub getfilepath()
    
54. On Error Resume Next
    
55.     Dim i%
    
56.     i = 1
    
57.      Do
    
58.      myfilepath = "z:\报价文件\ MSGM(JS)" & "_" & Range("B2") & "_TO " & Range("B6") & "." & Range("B7") & "." & Range("G6") & " ( " & "报价" & " ) " & "_ FROM." & Range("F3") & " ( " & Range("H3") & " ) _" & Range("D2") & "_V" & i & ".00" & ".xlsx"
    
59.      i = i + 1
    
60.     Loop Until Not IsFileExists(myfilepath)
    
61. End Sub
    
62. 
    
63. Private Function IsFileExists(ByVal strFileName As String) As Boolean
    
64. On Error Resume Next
    
65.     If Dir(strFileName, 16) <> Empty Then
    
66.         IsFileExists = True
    
67.     Else
    
68.         IsFileExists = False
    
69.     End If
    
70. End Function

复制代码

最佳答案

月排行榜 / 总排行榜

zjdh

2016-7-1 16:05

myFolder = "z:\报价文件"
改成
myFolder = ThisWorkbook.Path  &  "\报价文件"

myfilepath = "z:\报价文件\ MSGM(JS)" ......
改成
myfilepath =  ThisWorkbook.Path & "\报价文件\ MSGM(JS)" .........


MsgBox "数据已被导出, " & myfilepath    '保存在D:\报价文件\...", 48, "导出提示"
改成
MsgBox "数据已被导出, " & myfilepath  & "保存在" &  ThisWorkbook.Path &  "\报价文件\...", 48, "导出提示"

跳转到最佳答案楼层

zjdh

myFolder = "z:\报价文件"
改成
myFolder = ThisWorkbook.Path  &  "\报价文件"

myfilepath = "z:\报价文件\ MSGM(JS)" ......
改成
myfilepath =  ThisWorkbook.Path & "\报价文件\ MSGM(JS)" .........


MsgBox "数据已被导出, " & myfilepath    '保存在D:\报价文件\...", 48, "导出提示"
改成
MsgBox "数据已被导出, " & myfilepath  & "保存在" &  ThisWorkbook.Path &  "\报价文件\...", 48, "导出提示"

daxindianqi

zjdh 发表于 2016-7-1 16:05
myFolder = "z:\报价文件"
改成
myFolder = ThisWorkbook.Path  &  "\报价文件"

OK了  谢谢