我制作了一个宏来将我的xlsm文件导出到csv文件中。它在一台计算机上运行良好，其中服务器的目录是＆＃34;我＆＃34;但是在另一台计算机上将同一台服务器保存到目录＆＃34; T＆＃34;它失败。有这个多目录/多计算机问题的解决方案吗？修剪后的代码附有指出的目录行。
Sub ExportAsCSV()
Dim Answer As VbMsgBoxResult, Dir As String, LastRow As Long, _
Date1 As Date, Date2 As Date, CSVFileName As String
' *********************************************************
' Directory String <---------------- The Issue
Dir = "I:\2017\CVS" ' Could be "I:\", could be "T:\" ...
' *********************************************************
' Creating the Name of the CSV File using the _
' first and last date in column C (C1 is a header)
LastRow = Cells(Rows.Count, "C").End(xlUp).Row
Date1 = Range("C2").Value
Date2 = Cells(LastRow, "C")
If Date1 < Date2 Then
CSVFileName = "FILE." & Format(Date1, "mm.dd.yy") & _
"-" & Format(Date2, "mm.dd.yy") & ".csv"
ElseIf Date1 > Date2 Then
CSVFileName = "FILE." & Format(Date2, "mm.dd.yy") & _
"-" & Format(Date1, "mm.dd.yy") & ".csv"
Else
CSVFileName = "FILE." & Format(Date1, "mm.dd.yy") & ".csv"
End If
' Double Check User wants to make a sheet Response
Answer = MsgBox("Clicking 'Yes' will create a CSV file named " & vbCrLf & vbCrLf & _
" " & CSVFileName & vbCrLf & vbCrLf & _
"into " & vbCrLf & vbCrLf & " " & Dir & vbCrLf & vbCrLf & _
"It will overwrite any CSV with an identical name." & vbCrLf & vbCrLf & _
"Is this what you want to do?", vbYesNo + vbQuestion)
'Act based on the Response
If Answer = vbYes Then
' Ready all cells for csv creation
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")
ws.Copy
ActiveWorkbook.SaveAs FileName:=Dir & "\" & CSVFileName, _
FileFormat:=xlCSV, CreateBackup:=False
MsgBox ("Created the csv file:" & vbCrLf & vbCrLf & _
Dir & "\" & CSVFileName)
Else
MsgBox ("Did not create the csv file.")
End If
End Sub
感谢任何帮助。
答案 0 :(得分：1)
您需要使用UNC路径而不是映射的网络驱动器。
Global myDoc As HTMLDocument
Global IE As Object
Sub StartHere()
On Error Resume Next
ThisWorkbook.VBProject.References.AddFromGuid "{420B2830-E718-11CF-893D-00A0C9054228}", 0, 0 'Microsoft Scripting Runtime
ThisWorkbook.VBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 0, 0 'Microsoft Extensability for VBA
ThisWorkbook.VBProject.References.AddFromGuid "{0D452EE1-E08F-101A-852E-02608C4D0BB4}", 0, 0 'Microsoft Forms
ThisWorkbook.VBProject.References.AddFromGuid "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}", 0, 0 'Microsoft MSHTML
ThisWorkbook.VBProject.References.AddFromGuid "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}", 0, 0 'Microsoft Internet Controls
On Error GoTo 0
Call nextSub
End Sub
Sub nextSub()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.codemodule
Dim LineNum As Long
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents("Module1")
Set CodeMod = VBComp.codemodule
LineNum = 1
CodeMod.insertlines 1, "Global myDoc As HTMLDocument"
CodeMod.insertlines 2, "Global IE As Object"
Call getOpenBrowserCreateForm
End Sub
Sub removeCode()
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents("Module1")
Set CodeMod = VBComp.codemodule
LineNum = 1
For i = 34 To 4 Step -1
CodeMod.DeleteLines i
Next i
End Sub
Public myDoc As HTMLDocument
Public IE As Object
Sub getOpenBrowserCreateForm()
Dim myForm As Object
Dim NewFrame As MSForms.Frame
Dim NewButton As MSForms.CommandButton, newButton2 As MSForms.CommandButton
'Dim NewComboBox As MSForms.ComboBox
Dim NewListBox As MSForms.ListBox
'Dim NewTextBox As MSForms.TextBox
'Dim NewLabel As MSForms.Label
'Dim NewOptionButton As MSForms.OptionButton
'Dim NewCheckBox As MSForms.CheckBox
Dim x As Integer
Dim Line As Integer
'This is to stop screen flashing while creating form
Application.VBE.MainWindow.Visible = False
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\mshtml.tlb"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\System32\ieframe.dll"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\system32\FM20.DLL"
On Error GoTo 0
Set myForm = ThisWorkbook.VBProject.VBComponents.Add(3)
'Create the User Form
With myForm
.Properties("Caption") = "Select Open Web Site"
.Properties("Width") = 326
.Properties("Height") = 280
End With
'Create ListBox
Set NewListBox = myForm.designer.Controls.Add("Forms.listbox.1")
With NewListBox
.Name = "ListBox1"
.Top = 12
.Left = 12
.Width = 297
.Height = 207.8
.Font.Size = 9
.Font.Name = "Tahoma"
.BorderStyle = fmBorderStyleOpaque
.SpecialEffect = fmSpecialEffectSunken
End With
'Create CommandButton1 Create
Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "CommandButton1"
.Caption = "Select"
.Accelerator = "M"
.Top = 228
.Left = 234
.Width = 72
.Height = 24
.Font.Size = 9
.Font.Name = "Tahoma"
.BackStyle = fmBackStyleOpaque
End With
'Create CommandButton2 Create
Set NewButton = myForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "CommandButton2"
.Caption = "Cancel"
.Accelerator = "M"
.Top = 228
.Left = 144
.Width = 72
.Height = 24
.Font.Size = 9
.Font.Name = "Tahoma"
.BackStyle = fmBackStyleOpaque
End With
'add code for form module
myForm.codemodule.insertlines 1, "Private Sub CommandButton1_Click()"
myForm.codemodule.insertlines 2, "Dim urlLocation As String"
myForm.codemodule.insertlines 3, ""
myForm.codemodule.insertlines 4, "''////////////////////////////////////////////////////////////////////"
myForm.codemodule.insertlines 5, "'' This part gets all open web pages qand displays them on the form for user to choose"
myForm.codemodule.insertlines 6, "''"
myForm.codemodule.insertlines 7, " Set objIterator = CreateObject(" & Chr(34) & "Shell.Application" & Chr(34) & ")"
myForm.codemodule.insertlines 8, " For X = 0 To objIterator.Windows.Count"
myForm.codemodule.insertlines 9, " On Error Resume Next"
myForm.codemodule.insertlines 10, " current_title = objIterator.Windows(X).Document.Title"
myForm.codemodule.insertlines 11, " current_url = objIterator.Windows(X).Document.Location"
myForm.codemodule.insertlines 12, " "
myForm.codemodule.insertlines 13, " If current_title = ListBox1.Value Then 'is this my webpage?"
myForm.codemodule.insertlines 14, " "
myForm.codemodule.insertlines 15, " Set IE = objIterator.Windows(X)"
myForm.codemodule.insertlines 16, " MsgBox " & Chr(34) & "IE was properly set" & Chr(34) & ""
myForm.codemodule.insertlines 17, " "
myForm.codemodule.insertlines 18, " Boolean_indicator = True"
myForm.codemodule.insertlines 19, " Exit For"
myForm.codemodule.insertlines 20, " End If"
myForm.codemodule.insertlines 21, " Next"
myForm.codemodule.insertlines 22, " Set objIterator = Nothing"
myForm.codemodule.insertlines 23, " Set myDoc = IE.Document"
myForm.codemodule.insertlines 24, "Return"
myForm.codemodule.insertlines 25, "Unload Me"
myForm.codemodule.insertlines 26, ""
myForm.codemodule.insertlines 27, "End Sub"
myForm.codemodule.insertlines 28, ""
myForm.codemodule.insertlines 29, ""
myForm.codemodule.insertlines 30, "Private Sub CommandButton2_Click()"
myForm.codemodule.insertlines 31, " Unload Me"
myForm.codemodule.insertlines 32, "End Sub"
myForm.codemodule.insertlines 33, ""
myForm.codemodule.insertlines 34, ""
myForm.codemodule.insertlines 35, "Private Sub UserForm_Activate()"
myForm.codemodule.insertlines 36, " Dim myArray1() As String, tempNumb As Integer"
myForm.codemodule.insertlines 37, " "
myForm.codemodule.insertlines 38, " "
myForm.codemodule.insertlines 39, " i = 2"
myForm.codemodule.insertlines 40, " tempNumb = 1"
myForm.codemodule.insertlines 41, " "
myForm.codemodule.insertlines 42, " ReDim myArray1(1 To 1)"
myForm.codemodule.insertlines 43, " "
myForm.codemodule.insertlines 44, " Set objShell = CreateObject(" & Chr(34) & "Shell.Application" & Chr(34) & ")"
myForm.codemodule.insertlines 45, " Set objAllWindows = objShell.Windows"
myForm.codemodule.insertlines 46, " "
myForm.codemodule.insertlines 47, " "
myForm.codemodule.insertlines 48, " For Each ow In objAllWindows"
myForm.codemodule.insertlines 49, " If (InStr(1, ow," & Chr(34) & "Internet Explorer" & Chr(34) & ", vbTextCompare)) Then"
myForm.codemodule.insertlines 50, " myArray1(tempNumb) = ow.Document.Title"
myForm.codemodule.insertlines 51, " tempNumb = tempNumb + 1"
myForm.codemodule.insertlines 52, " If Not ow.Document.Title = " & Chr(34) & "" & Chr(34) & " Then"
myForm.codemodule.insertlines 53, " ReDim Preserve myArray1(1 To tempNumb)"
myForm.codemodule.insertlines 54, " Else"
myForm.codemodule.insertlines 55, " Exit For"
myForm.codemodule.insertlines 56, " End If"
myForm.codemodule.insertlines 57, " End If"
myForm.codemodule.insertlines 58, " Next"
myForm.codemodule.insertlines 59, " "
myForm.codemodule.insertlines 60, " Me.ListBox1.List = myArray1"
myForm.codemodule.insertlines 61, "End Sub"
myForm.codemodule.insertlines 62, ""
'Show the form
VBA.UserForms.Add(myForm.Name).Show
'Delete the form (Optional)
Application.VBE.MainWindow.Visible = True
ThisWorkbook.VBProject.VBComponents.Remove myForm
' IE is now set to the user's choice and you can add code here to interact with it
' myDoc is now set to IE.Document also
'
'
'
Dim drp As HTMLFormElement
Set drp = myDoc.getelementsbyname("suppliercode")(0)
Dim walekuj As Long
walekuj = myDoc.forms.Length
MsgBox walekuj
'we get the option values into our worksheet
For x = 0 To 3
Cells(x + 1, 1) = drp.Item(x).innerText
Next x
'Now we select the option value of our choice
drp.selectedIndex = 2
' we free memory
Set IE = Nothing
Application.StatusBar = ""
End Sub
如果您不知道网络驱动器指向的服务器/文件夹，请询问您的网络管理员。
您不应该以隐藏/影子全局命名空间中已存在的标识符的方式命名：Dir = "\\ServerName\SomeFolder\2017\CVS"
实际上是Dir模块中的一个函数;通过声明一个VBA.FileSystem局部变量，您的名称可能会对读者造成不明确的影响（尽管编译器并不关心）。