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

我很高兴能在这里与伟大的程序员在一起，希望我能学到很多东西。我也是这种编程的新手，所以我很抱歉给您带来不便

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

我想为我的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

此更新的代码为您提供了一个SaveAs name选项，默认为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

更新代码

更高效的csv代码

从

此代码必须从常规VBA代码模块运行。否则，如果用户尝试在给定Const用法的ThisWorkbook或Sheet code窗格中运行代码，则该代码将导致错误。 值得注意的是，This工作簿和工作表代码部分应仅保留用于事件编码，普通VBA应从标准代码模块运行。 请注意，出于示例代码的目的，CSV输出文件的文件路径在代码顶部硬编码为：C:\test\myfile.CSV。您可能希望以编程方式设置输出文件，例如作为函数参数。 如前所述；例如，此代码可转换列和行；也就是说，输出文件为选定范围内的每列包含一个CSV行。通常情况下，CSV输出是逐行的，与屏幕上可见的布局相呼应，但我想说明的是，使用VBA代码生成输出提供的选项超出了可用的选项，例如，使用“另存为…”。。。CSV文本菜单选项。 代码

---

您的代码似乎只是将ActiveWorkbook的第一张工作表保存为CSV。brojac测试将在sheet1之后退出。您可以更改这一行，打开csvPath&\&&uuuLeftActiveWorkbook.Name，LenActiveWorkbook.Name-5&.csv作为nFileNum输出，以更改文件保存路径。我知道所有这些。问题是我不知道如何更改它，因为我不知道执行该操作的命令。我需要在它生成我的CSV后，它打开我的另存为选项，我选择保存CSV文件的位置。修复如下。增加了更快的CSV代码样本到boot，这就是我一直在寻找的。这意味着我需要这样的命令：Application.GetSaveAsFilename。我不知道这是什么命令。谢谢你，先生。我真的很感谢你的帮助。

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

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