如何在 Excel by VBA 中为 CSV 文件的导出(另存为)定义字段分隔符、编码和记录分隔符 ({CR}{LF})
How can Defining fields delimiter character, Encoding and Records seperator ({CR}{LF}) for CSV files in export (Save As) from Excel by VBA
我将 Save As
我的 sheet 以 CSV 格式与(逗号分隔)“,”(用于字段)和 {CR}{LF} 用于按以下代码排列的记录。
问题是:
1) 生成的文件以“;”分隔符号而不是“,”。
2) 确保记录由 {CR}{LF} 分隔
3) 如何将编码定义为 Unicode UTF-8(在需要的情况下)
我希望此文件以 .txt 扩展名保存。
如何根据上述情况生成真实格式的CSV文件?
Sub GenCSV()
Dim NewBook As Workbook
Set NewBook = Workbooks.Add
ThisWorkbook.Worksheets("Sheet1").Range("tblTaxRep[[Header1]: _
[Headern]]").SpecialCells(xlCellTypeVisible).Copy
With NewBook
.Worksheets("Sheet1").Cells(1, 1).PasteSpecial (xlPasteValues)
.SaveAs Filename:=ThisWorkbook.Path & "Report" & ".txt", FileFormat:=xlCSV
.Close SaveChanges:=False
End With
End Sub
Option Explicit
Const strDelimiter = """"
Const strDelimiterEscaped = strDelimiter & strDelimiter
Const strSeparator = ","
Const strRowEnd = vbCrLf
Const strCharset = "utf-8"
Function CsvFormatString(strRaw As String) As String
Dim boolNeedsDelimiting As Boolean
boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _
Or InStr(1, strRaw, Chr(10)) > 0 _
Or InStr(1, strRaw, strSeparator) > 0
CsvFormatString = strRaw
If boolNeedsDelimiting Then
CsvFormatString = strDelimiter & _
Replace(strRaw, strDelimiter, strDelimiterEscaped) & _
strDelimiter
End If
End Function
Function CsvFormatRow(rngRow As Range) As String
Dim arrCsvRow() As String
ReDim arrCsvRow(rngRow.Cells.Count - 1)
Dim rngCell As Range
Dim lngIndex As Long
lngIndex = 0
For Each rngCell In rngRow.Cells
arrCsvRow(lngIndex) = CsvFormatString(rngCell.Text)
lngIndex = lngIndex + 1
Next rngCell
CsvFormatRow = Join(arrCsvRow, ",") & strRowEnd
End Function
Sub CsvExportRange( _
rngRange As Range, _
Optional strFileName As Variant _
)
Dim rngRow As Range
Dim objStream As Object
If IsMissing(strFileName) Or IsEmpty(strFileName) Then
strFileName = Application.GetSaveAsFilename( _
InitialFileName:=ActiveWorkbook.Path & "\" & rngRange.Worksheet.Name & ".csv", _
FileFilter:="CSV (*.csv), *.csv", _
Title:="Export CSV")
End If
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 2
objStream.Charset = strCharset
objStream.Open
For Each rngRow In rngRange.Rows
objStream.WriteText CsvFormatRow(rngRow)
Next rngRow
objStream.SaveToFile strFileName, 2
objStream.Close
End Sub
Sub CsvExportSelection()
CsvExportRange ActiveWindow.Selection
End Sub
Sub CsvExportSheet(varSheetIndex As Variant)
Dim wksSheet As Worksheet
Set wksSheet = Sheets(varSheetIndex)
CsvExportRange wksSheet.UsedRange
End Sub
我将 Save As
我的 sheet 以 CSV 格式与(逗号分隔)“,”(用于字段)和 {CR}{LF} 用于按以下代码排列的记录。
问题是:
1) 生成的文件以“;”分隔符号而不是“,”。
2) 确保记录由 {CR}{LF} 分隔
3) 如何将编码定义为 Unicode UTF-8(在需要的情况下)
我希望此文件以 .txt 扩展名保存。
如何根据上述情况生成真实格式的CSV文件?
Sub GenCSV()
Dim NewBook As Workbook
Set NewBook = Workbooks.Add
ThisWorkbook.Worksheets("Sheet1").Range("tblTaxRep[[Header1]: _
[Headern]]").SpecialCells(xlCellTypeVisible).Copy
With NewBook
.Worksheets("Sheet1").Cells(1, 1).PasteSpecial (xlPasteValues)
.SaveAs Filename:=ThisWorkbook.Path & "Report" & ".txt", FileFormat:=xlCSV
.Close SaveChanges:=False
End With
End Sub
Option Explicit
Const strDelimiter = """"
Const strDelimiterEscaped = strDelimiter & strDelimiter
Const strSeparator = ","
Const strRowEnd = vbCrLf
Const strCharset = "utf-8"
Function CsvFormatString(strRaw As String) As String
Dim boolNeedsDelimiting As Boolean
boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _
Or InStr(1, strRaw, Chr(10)) > 0 _
Or InStr(1, strRaw, strSeparator) > 0
CsvFormatString = strRaw
If boolNeedsDelimiting Then
CsvFormatString = strDelimiter & _
Replace(strRaw, strDelimiter, strDelimiterEscaped) & _
strDelimiter
End If
End Function
Function CsvFormatRow(rngRow As Range) As String
Dim arrCsvRow() As String
ReDim arrCsvRow(rngRow.Cells.Count - 1)
Dim rngCell As Range
Dim lngIndex As Long
lngIndex = 0
For Each rngCell In rngRow.Cells
arrCsvRow(lngIndex) = CsvFormatString(rngCell.Text)
lngIndex = lngIndex + 1
Next rngCell
CsvFormatRow = Join(arrCsvRow, ",") & strRowEnd
End Function
Sub CsvExportRange( _
rngRange As Range, _
Optional strFileName As Variant _
)
Dim rngRow As Range
Dim objStream As Object
If IsMissing(strFileName) Or IsEmpty(strFileName) Then
strFileName = Application.GetSaveAsFilename( _
InitialFileName:=ActiveWorkbook.Path & "\" & rngRange.Worksheet.Name & ".csv", _
FileFilter:="CSV (*.csv), *.csv", _
Title:="Export CSV")
End If
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 2
objStream.Charset = strCharset
objStream.Open
For Each rngRow In rngRange.Rows
objStream.WriteText CsvFormatRow(rngRow)
Next rngRow
objStream.SaveToFile strFileName, 2
objStream.Close
End Sub
Sub CsvExportSelection()
CsvExportRange ActiveWindow.Selection
End Sub
Sub CsvExportSheet(varSheetIndex As Variant)
Dim wksSheet As Worksheet
Set wksSheet = Sheets(varSheetIndex)
CsvExportRange wksSheet.UsedRange
End Sub