Question

如何修改以下VBA代码以使其在Win10上运行？它在Win8.1上运行良好。在我的Win10计算机上，它创建目录但无法保存csv。

此代码是我自己编写的附加部分，为数据获取代码添加了保存csv功能（来源：http://investexcel.net）。

以下是我在运行整个宏时收到的错误消息（在使Application.DisplayAlerts = True之后）

无法访问
'16 .csdv'。该文件可能已损坏，位于未响应的服务器上，或者只读。（选项 - 重试/取消）

按下取消后出现此错误：

运行时错误1004：应用程序定义或对象定义错误

按调试将我带到这部分代码（以黄色突出显示）

    ActiveSheet.SaveAs Filename:=FName, _
    FileFormat:=xlCSV, CreateBackup:=False

这是保存CSV的整个代码体。

Dim strName As String
Dim strDirname, Path, strDefpath As String
Dim FName As String

On Error Resume Next ' If directory exist goto next line

'Now we check if export folder exists. If not then it gets created here


If Len(Dir("Z:\MyBackfill\Extracts\", vbDirectory)) = 0 Then
MkDir "Z:\MyBackfill\Extracts\"
End If

strDirname = Format(CStr(Now), "DDMMMYY") ' New directory name
strDefpath = "Z:\MyBackfill\Extracts\"
MkDir strDefpath & strDirname
Path = strDefpath & strDirname & "\"  'create total string
dt = Format(CStr(Now), "DDMMMYY HHMMSS")



Worksheets("Data").Activate
Range("G8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "dd-MM-yy HH:mm:ss"
Columns("G:G").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Columns("G:G").Select
Application.CutCopyMode = False


With ActiveSheet

 lLastRow = .Columns("G:G").Cells(.Rows.Count, 1).End(xlUp).Row

 ReDim arrDate(1 To lLastRow) As Long
 ReDim arrTime(1 To lLastRow) As Double
 arrDateTimes = .Range("G1:G" & lLastRow).Value
 For lRow = LBound(arrDateTimes) To UBound(arrDateTimes)
 arrDate(lRow) = Int(arrDateTimes(lRow, 1))
 arrTime(lRow) = arrDateTimes(lRow, 1) - arrDate(lRow)
 Next
 .Range("H1:H" & lLastRow).Value = WorksheetFunction.Transpose(arrDate)
 .Range("I1:I" & lLastRow).Value = WorksheetFunction.Transpose(arrTime)
 .Range("H1:H" & lLastRow).NumberFormat = "dd-mm-yy"
 .Range("I1:I" & lLastRow).NumberFormat = "hh:mm:ss"

 End With


 ' Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
 '    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
 '   Semicolon:=False, Comma:=True, Space:=True, Other:=False, FieldInfo:= _
  '  Array(1, 2), TrailingMinusNumbers:=True


 Range("G8").Select
 Range(Selection, Selection.End(xlDown)).Select
 Selection.NumberFormat = "dd-MM-yy"
 Range("H8").Select
 Range(Selection, Selection.End(xlDown)).Select
 Selection.NumberFormat = "HH:mm:ss"

 Columns("H:I").Select
 Selection.Cut
 Columns("B:B").Select
 Selection.Insert Shift:=xlToRight

Columns("Z:I").Select
Selection.Delete Shift:=xlToLeft

Range("B8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "dd-MM-yy"
Range("C8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "HH:mm:ss"


Range("A8").Select
ActiveCell.FormulaR1C1 = "=Parameters!R[5]C[1]"
Range("A8").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("A8").Select
Application.CutCopyMode = False
'Selection.AutoFill Destination:=Range("A8:A4520")
Selection.AutoFill Destination:=Range("A8:A" & Range("B" & Rows.Count).End(xlUp).Row)
'Range("A8:A4520").Select
Columns("G:G").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("D:D").Select
Selection.Cut
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Rows("1:7").Select
Range("A7").Activate
Selection.Delete Shift:=xlUp


'ADDING 59 to Seconds for correct backfill//////////////////////////////////////////
Dim cell As Range
For Each cell In Range("C1", Range("C1").End(xlDown))
cell.Value = Left$(cell.Value, 6) & "59"
Next




'Filename = "GFill" & " " & DataSheet.Range("A1").Value & " " & dt & " " & "FROM" & "_" & DataSheet.Range("B1").Value & ".csv"
Filename = "GFill" & " " & "NIFTY" & " " & dt & " " & "FROM" & "_" & DataSheet.Range("B1").Value & ".csv"
FName = Path & Filename


Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
'ChDir "C:\Users\Vaibhav\Desktop"
ActiveSheet.SaveAs Filename:=FName, _
    FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Save
ActiveWindow.Close
Selection.QueryTable.Delete
Selection.ClearContents
Range("A1").Select
ActiveWorkbook.Save

Answer 1

这有点棘手。

MkDir函数无法一次创建Drive:\Directory\Subdirectory - 它正在尝试在不存在的目录中创建子目录，因此您首先必须创建目录，并且然后你可以用它来创建子目录：

MkDir "Drive:\Directory"
MkDir "Drive:\Directory\Subdirectory"

因此，这很可能解释了为什么即使在Win10机器的C驱动器上也会出现故障。

关于Z＆amp; E驱动器（假设那些是共享）如果您没有从Win10机器访问或写入这些驱动器的权限，则会发生类似的错误;这不是一个可以用VBA解决的问题，除非它是一个简单的驱动器号映射问题，在这种情况下你可以通过提供完整的规范路径解决它，例如：

MkDir "\\servername\Directory"

由于您仍然在SaveAs上收到错误，请检查Fname的值。

您从以下位置提取日期值：

DataSheet.Range("B1").Value

这包括不能在文件名中使用的正斜杠字符。

尝试改为：

Format(DataSheet.Range("B1").Value, "yyyymmdd")

Answer 2

感谢David Zemens。

他指着我立即使用窗户。

问题出现了，因为某些原因＆＃34; /＆＃34;文件名出现了，不应该。

适当编辑FileName变量以删除＆＃34; /＆＃34;并正确生成文件。

请注意，win8.1中没有出现同样的问题

Excel Macro能够在Win8.1上保存csv但停止在Win10上保存/工作

2 个答案: