从XLS到CSV – macros另存为视觉选项

我很高兴能在这里与伟大的程序员，并希望我会学到很多。 我在这种编程方面也是新手，所以对于任何不便，我深感抱歉。

我正在使用下面的vba代码将我的文件从XLS传输到CSV 。 将xls文件转换为csv格式后，会自动将我新创build的csv文件保存在与我原来的xls文件相同的目录中。

我想为我的csv文件名Save As选项

先谢谢你。

 ' ---------------------- Directory Choosing Helper Functions ----------------------- ' Excel and VBA do not provide any convenient directory chooser or file chooser ' dialogs, but these functions will provide a reference to a system DLL ' with the necessary capabilities Private Type BROWSEINFO ' used by the function GetFolderName hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Function GetFolderName(Msg As String) As String ' returns the name of the folder selected by the user Dim bInfo As BROWSEINFO, path As String, r As Long Dim X As Long, pos As Integer bInfo.pidlRoot = 0& ' Root folder = Desktop If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." ' the dialog title Else bInfo.lpszTitle = Msg ' the dialog title End If bInfo.ulFlags = &H1 ' Type of directory to return X = SHBrowseForFolder(bInfo) ' display the dialog ' Parse the result path = Space$(512) r = SHGetPathFromIDList(ByVal X, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetFolderName = Left(path, pos - 1) Else GetFolderName = "" End If End Function '---------------------- END Directory Chooser Helper Functions ---------------------- Public Sub DoTheExport() Dim FName As Variant Dim Sep As String Dim wsSheet As Worksheet Dim nFileNum As Integer Dim csvPath As String Sep = ";" csvPath = Application.ActiveWorkbook.path Dim brojac As Integer brojac = 0 For Each wsSheet In Worksheets If brojac > 0 Then Exit For wsSheet.Activate nFileNum = FreeFile Open csvPath & "\" & _ Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & ".csv" For Output As #nFileNum ' wsSheet.Name ExportToTextFile CStr(nFileNum), Sep, False Close nFileNum brojac = brojac + 1 Next wsSheet End Sub Public Sub ExportToTextFile(nFileNum As Integer, _ Sep As String, SelectionOnly As Boolean) Dim WholeLine As String Dim RowNdx As Long Dim ColNdx As Integer Dim StartRow As Long Dim EndRow As Long Dim StartCol As Integer Dim EndCol As Integer Dim CellValue As String Application.ScreenUpdating = False On Error GoTo EndMacro: If SelectionOnly = True Then With Selection StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With Else With ActiveSheet.UsedRange StartRow = .Cells(1).Row StartCol = .Cells(1).Column EndRow = .Cells(.Cells.Count).Row EndCol = .Cells(.Cells.Count).Column End With End If For RowNdx = StartRow To EndRow WholeLine = "" For ColNdx = StartCol To EndCol If Cells(RowNdx, ColNdx).Value = "" Then CellValue = "" Else CellValue = Cells(RowNdx, ColNdx).Value End If WholeLine = WholeLine & CellValue & Sep Next ColNdx WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) Print #nFileNum, WholeLine Next RowNdx EndMacro: On Error GoTo 0 Application.ScreenUpdating = True End Sub 

问题可能在这里。 这部分代码必须重新编写或更正。 这是调用其他的主要function。

 Public Sub DoTheExport() Dim FName As Variant Dim Sep As String Dim wsSheet As Worksheet Dim nFileNum As Integer Dim csvPath As String Sep = ";" csvPath = Application.ActiveWorkbook.path Dim brojac As Integer brojac = 0 For Each wsSheet In Worksheets If brojac > 0 Then Exit For wsSheet.Activate nFileNum = FreeFile Open csvPath & "\" & _ Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5) & ".csv" For Output As #nFileNum ' wsSheet.Name ExportToTextFile CStr(nFileNum), Sep, False Close nFileNum brojac = brojac + 1 Next wsSheet End Sub 

Answer 1

1. 此更新后的代码为您提供SaveAs名称选项（默认为WorkbookName.csv ）
2. 更有效的代码使用变种arrays，使您的csv下面。

这是三个关键的更新线：

 strFileName = Application.GetSaveAsFilename(Left$(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5), "CSV (Comma delimited) (*.csv), *.csv") If strFileName = "False" Then Exit Sub Open strFileName For Output As #nFileNum 

更新的代码

 Public Sub DoTheExport() Dim FName As Variant Dim Sep As String Dim wsSheet As Worksheet Dim nFileNum As Integer Dim csvPath As String Dim strFileName As String Sep = ";" csvPath = Application.ActiveWorkbook.path Dim brojac As Long brojac = 0 For Each wsSheet In Worksheets If brojac > 0 Then Exit For wsSheet.Activate nFileNum = FreeFile strFileName = Application.GetSaveAsFilename(Left$(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5), "CSV (Comma delimited) (*.csv), *.csv") If strFileName = "False" Then Exit Sub Open strFileName For Output As #nFileNum ExportToTextFile CStr(nFileNum), Sep, False Close nFileNum brojac = brojac + 1 Next wsSheet End Sub 

更有效的csv代码

使用Excel VBA创build和写入CSV文件

1. 此代码必须从常规的VBA代码模块运行。 否则，如果用户尝试从给定Const的用法的ThisWorkbook或Sheet Code窗格中运行代码，则代码将会导致错误。
2. 值得注意的是， ThisWorkbook和Sheet代码部分应该只保留给事件编码，“正常”的VBA应该从标准的代码模块运行。
3. 请注意，出于示例代码的目的，CSV输出文件的文件path是“硬编码”，如代码顶部的C:\test\myfile.csv 。 您可能需要以编程方式设置输出文件，例如作为函数参数。
4. 如前面提到的; 举例来说，这个代码TRANSPOSES COLUMNS AND ROWS ; 也就是说，输出文件包含所选范围中每列的一个CSV行。 通常情况下，CSV输出将是逐行的，回显屏幕上可见的布局，但我想演示使用VBA代码生成输出提供超出可用的选项，例如，使用Save As... CSV Text菜单选项。

码

 Const sFilePath = "C:\test\myfile.csv" Const strDelim = "," Sub CreateCSV_Output() Dim ws As Worksheet Dim rng1 As Range Dim X Dim lRow As Long Dim lCol As Long Dim strTmp As String Dim lFnum As Long lFnum = FreeFile Open sFilePath For Output As lFnum For Each ws In ActiveWorkbook.Worksheets 'test that sheet has been used Set rng1 = ws.UsedRange If Not rng1 Is Nothing Then 'only multi-cell ranges can be written to a 2D array If rng1.Cells.Count > 1 Then X = ws.UsedRange.Value2 'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column For lCol = 1 To UBound(X, 2) 'write initial value outside the loop strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol)) For lRow = 2 To UBound(X, 1) 'concatenate long string & (short string with short string) strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol))) Next lRow 'write each line to CSV Print #lFnum, strTmp Next lCol Else Print #lFnum, IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value) End If End If Next ws Close lFnum MsgBox "Done!", vbOKOnly End Sub Sub CreateCSV_FSO() Dim objFSO Dim objTF Dim ws As Worksheet Dim lRow As Long Dim lCol As Long Dim strTmp As String Dim lFnum As Long Set objFSO = CreateObject("scripting.filesystemobject") Set objTF = objFSO.createtextfile(sFilePath, True, False) For Each ws In ActiveWorkbook.Worksheets 'test that sheet has been used Set rng1 = ws.UsedRange If Not rng1 Is Nothing Then 'only multi-cell ranges can be written to a 2D array If rng1.Cells.Count > 1 Then X = ws.UsedRange.Value2 'The code TRANSPOSES COLUMNS AND ROWS by writing strings column by column For lCol = 1 To UBound(X, 2) 'write initial value outside the loop strTmp = IIf(InStr(X(1, lCol), strDelim) > 0, """" & X(1, lCol) & """", X(1, lCol)) For lRow = 2 To UBound(X, 1) 'concatenate long string & (short string with short string) strTmp = strTmp & (strDelim & IIf(InStr(X(lRow, lCol), strDelim) > 0, """" & X(lRow, lCol) & """", X(lRow, lCol))) Next lRow 'write each line to CSV objTF.writeline strTmp Next lCol Else objTF.writeline IIf(InStr(ws.UsedRange.Value, strDelim) > 0, """" & ws.UsedRange.Value & """", ws.UsedRange.Value) End If End If Next ws objTF.Close Set objFSO = Nothing MsgBox "Done!", vbOKOnly End Sub