Question

以下代码成功将大型Excel文件转换为具有指定行数的csv文件。我怎么希望输出文件是UTF-8编码的CSV文件。

如何将UTF-8代码添加到下面，我想将下面的拆分文件代码与UTF-8转换代码结合起来

Sub test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
  Dim NumOfColumns As Integer
  Dim RangeToCopy As Range
  Dim RangeOfHeader As Range        'data (range) of header row
  Dim WorkbookCounter As Integer
  Dim RowsInFile                    'how many rows (incl. header) in new files?
  Application.ScreenUpdating = False

  'Initialize data
  Set ThisSheet = ThisWorkbook.ActiveSheet
  NumOfColumns = ThisSheet.UsedRange.Columns.Count
  WorkbookCounter = 1
  RowsInFile = 5                   'as your example, just 10 rows per file

  'Copy the data of the first row (header)
  Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))

  For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1
    Set wb = Workbooks.Add

    'Paste the header row in new file
    RangeOfHeader.Copy wb.Sheets(1).Range("A1")

    'Paste the chunk of rows for this file
    Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))
    RangeToCopy.Copy wb.Sheets(1).Range("A2")

    'Save the new workbook, and close it
    wb.SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_v" & WorkbookCounter & ".csv", FileFormat:=xlCSV
    wb.Close True

    'Increment file counter
    WorkbookCounter = WorkbookCounter + 1
  Next p

  Application.ScreenUpdating = True
  Set wb = Nothing
End Sub

Answer 1

您可以使用ADODB库Stream对象。以下代码使用早期绑定，因此在运行之前不要忘记相应地勾选相关的MS ActiveX数据对象引用。

Sub saveAsUTF8()
    Dim myStream As ADODB.Stream
    Dim ws As Worksheet
    Dim curRow As String
    Dim curRowRng As Range
    Dim curCell As Range

    Set myStream = New ADODB.Stream

    Set ws = ThisWorkbook.ActiveSheet

    With myStream
        .Type = adTypeText
        .Charset = "UTF-8"
        .Open

        For Each curRowRng In ws.UsedRange.Rows
            curRow = ""
            For Each curCell In curRowRng.Cells
                curRow = curRow & "," & curCell.Value
            Next curCell
            curRow = Right(curRow, Len(curRow) - 1)
            .WriteText curRow, adWriteLine
        Next curRowRng

        'CHANGE TO YOU DESTINATION DIRECTORY
        .SaveToFile "YOUR_PATH\utf8file.csv", adSaveCreateOverWrite
        .Close

    End With

End Sub

使用UTF-8编码将电子表格/ excel文件拆分为多个csv文件

1 个答案: