Excel:宏将工作表导出为CSV文件而不离开当前的Excel工作表

问题描述 投票:19回答:4

这里有很多问题要创建一个宏来将工作表保存为CSV文件。所有答案都使用SaveAs,例如来自SuperUser的this one。他们基本上说要创建这样的VBA函数:

Sub SaveAsCSV()
    ActiveWorkbook.SaveAs FileFormat:=clCSV, CreateBackup:=False
End Sub

这是一个很好的答案,但我想要导出而不是另存为。当SaveAs被执行时,它会引起我两个烦恼:

  • 我当前的工作文件变为CSV文件。我想继续使用我原来的.xlsm文件,但要将当前工作表的内容导出到具有相同名称的CSV文件。
  • 出现一个对话框,要求我确认我要重写CSV文件。

是否可以将当前工作表导出为文件,但继续在原始文件中工作?

excel vba excel-vba csv export-to-csv
4个回答
21
投票

@NathanClement有点快。然而,这是完整的代码(稍微复杂一点):

Option Explicit

Public Sub ExportWorksheetAndSaveAsCSV()

Dim wbkExport As Workbook
Dim shtToExport As Worksheet

Set shtToExport = ThisWorkbook.Worksheets("Sheet1")     'Sheet to export as CSV
Set wbkExport = Application.Workbooks.Add
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
Application.DisplayAlerts = False                       'Possibly overwrite without asking
wbkExport.SaveAs Filename:="C:\tmp\test.csv", FileFormat:=xlCSV
Application.DisplayAlerts = True
wbkExport.Close SaveChanges:=False

End Sub

11
投票

几乎我想要@Ralph。您的代码有一些问题:

  1. 它只导出名为“Sheet1”的硬编码表;
  2. 它总是导出到相同的临时文件,覆盖它;
  3. 它忽略了locale分离字符。

为了解决这些问题,并满足我的所有要求,我改编了code from here。我已经清理了一点,使其更具可读性。

Option Explicit
Sub ExportAsCSV()

    Dim MyFileName As String
    Dim CurrentWB As Workbook, TempWB As Workbook

    Set CurrentWB = ActiveWorkbook
    ActiveWorkbook.ActiveSheet.UsedRange.Copy

    Set TempWB = Application.Workbooks.Add(1)
    With TempWB.Sheets(1).Range("A1")
      .PasteSpecial xlPasteValues
      .PasteSpecial xlPasteFormats
    End With        

    Dim Change below to "- 4"  to become compatible with .xls files
    MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) & ".csv"

    Application.DisplayAlerts = False
    TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
    TempWB.Close SaveChanges:=False
    Application.DisplayAlerts = True
End Sub

上面的代码还有一些小问题你应该注意到:

  1. .CloseDisplayAlerts=True应该是一个finally子句,但我不知道如何在VBA中做到这一点
  2. 它只是当前文件名有4个字母,如.xlsm。无法在.xls excel文件中使用。对于3个字符的文件扩展名,您必须在设置MyFileName时将- 5更改为- 4
  3. 作为附属效果,您的剪贴板将替换为当前的工作表内容。

编辑:将Local:=True保存到我的语言环境CSV分隔符。


0
投票

根据我对@neves帖子的评论,我通过添加xlPasteFormats以及值部分略微改进了这一点,因此日期作为日期进行 - 我主要将其保存为银行对帐单的CSV,因此需要日期。

Sub ExportAsCSV()

    Dim MyFileName As String
    Dim CurrentWB As Workbook, TempWB As Workbook

    Set CurrentWB = ActiveWorkbook
    ActiveWorkbook.ActiveSheet.UsedRange.Copy

    Set TempWB = Application.Workbooks.Add(1)
    With TempWB.Sheets(1).Range("A1")
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
    End With

    'Dim Change below to "- 4"  to become compatible with .xls files
    MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) & ".csv"

    Application.DisplayAlerts = False
    TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
    TempWB.Close SaveChanges:=False
    Application.DisplayAlerts = True
End Sub

-2
投票

正如我评论的那样,该网站上有一些地方将工作表的内容写入CSV。 This onethis one只指出了两个。

以下是我的版本

  • 它明确地在单元格中查找“,”
  • 它还使用UsedRange - 因为你想获得工作表中的所有内容
  • 使用数组进行循环,因为这比循环遍历工作表单元格更快
  • 我没有使用FSO例程,但这是一个选项

代码 ...

Sub makeCSV(theSheet As Worksheet)
Dim iFile As Long, myPath As String
Dim myArr() As Variant, outStr As String
Dim iLoop As Long, jLoop As Long

myPath = Application.ActiveWorkbook.Path
iFile = FreeFile
Open myPath & "\myCSV.csv" For Output Lock Write As #iFile

myArr = theSheet.UsedRange
For iLoop = LBound(myArr, 1) To UBound(myArr, 1)
    outStr = ""
    For jLoop = LBound(myArr, 2) To UBound(myArr, 2) - 1
        If InStr(1, myArr(iLoop, jLoop), ",") Then
            outStr = outStr & """" & myArr(iLoop, jLoop) & """" & ","
        Else
            outStr = outStr & myArr(iLoop, jLoop) & ","
        End If
    Next jLoop
    If InStr(1, myArr(iLoop, jLoop), ",") Then
        outStr = outStr & """" & myArr(iLoop, UBound(myArr, 2)) & """"
    Else
        outStr = outStr & myArr(iLoop, UBound(myArr, 2))
    End If
    Print #iFile, outStr
Next iLoop

Close iFile
Erase myArr

End Sub
© www.soinside.com 2019 - 2024. All rights reserved.