excel - 从 XLS 到 CSV - 宏另存为可视选项

Question

我很高兴和优秀的程序员一起来到这里，希望我能学到很多东西。我也是这种编程的新手，所以对于给您带来的不便，我深表歉意。

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

我想为我的文件名提供一个Save As选项csv

先感谢您。

' ---------------------- 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

问题大概就在这里。这部分代码必须重新编写或更正。这是调用其他函数的主要函数。

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

score 0 · Accepted Answer

此更新后的代码为您提供了 SaveAs 名称选项（默认为WorkbookName.csv）
更有效的代码使用变体数组来制作下面的 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 创建和写入 CSV 文件

此代码必须从常规 VBA 代码模块运行。否则，如果用户尝试从ThisWorkbook使用Const.
值得注意的是ThisWorkbook，Sheet 和 Sheet 代码部分应仅用于事件编码，“正常”VBA 应从标准代码模块运行。
请注意，出于示例代码的目的，CSV 输出文件的文件路径被“硬编码”为： C:\test\myfile.csv在代码的顶部。您可能希望以编程方式设置输出文件，例如作为函数参数。
如前面提到的; 例如，此代码转置列和行；也就是说，输出文件包含所选范围内每一列的一个 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

excel - 从 XLS 到 CSV - 宏另存为可视选项

1 回答 1

Related

Reference