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

时间：2013-04-01 06:57:08

标签： excel excel-vba excel-2010 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

1 个答案:

答案 0 :(得分：0)

  1. 此更新代码为您提供SaveAs名称选项（默认为 WorkbookName.csv ）
  2. 使用变体数组更高效的代码，使您的csv在下面。

    3. 这是三个关键的更新行：

    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代码

    来自Creating and Writing to a CSV File Using Excel VBA

    1. 此代码必须从常规VBA代码模块运行。否则，如果用户尝试使用ThisWorkbook使用Const或工作表代码窗格运行代码，则代码将导致错误。
    2. 值得注意的是，ThisWorkbook和Sheet代码部分应仅保留用于事件编码，“普通”VBA应从标准代码模块运行。
    3. 请注意，出于示例代码的目的，CSV输出文件的文件路径被“硬编码”为：代码顶部的C:\test\myfile.csv。您可能希望以编程方式设置输出文件，例如作为函数参数。
    4. 如前所述;例如，此代码 TRANSPOSES COLUMNS AND ROWS ;也就是说，输出文件包含所选范围中每列的一个CSV行。通常，CSV输出将是逐行的，与屏幕上可见的布局相呼应，但我想证明使用VBA代码生成输出提供的选项超出了可用范围，例如，使用Save As... CSV Text菜单选项。

      5. <强>码 

      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
相关问题
最新问题