将Excel里所有的Sheet页同时另存为单独的UTF8编码的CSV文件

最新推荐文章于 2025-03-17 15:47:52 发布

KiwiInChina

最新推荐文章于 2025-03-17 15:47:52 发布

阅读量1k

点赞数 1

CC 4.0 BY-SA版权

分类专栏： VBA 文章标签： ADODB VBA CSV UTF8 Sheet

本文链接：https://blog.youkuaiyun.com/clshangsha/article/details/84821902

VBA 专栏收录该内容

3 篇文章

订阅专栏

本文介绍了一段使用VBA代码从Excel工作簿中每个工作表导出单独CSV文件的方法。该过程首先创建一个临时文件夹，然后遍历每个工作表，将其内容转换为CSV格式并保存到指定路径下。代码还考虑了文件覆盖的情况，并确保最终消息提示文件生成成功。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

结合前两篇高手代码，拼出以下代码：

Public Sub WriteCSV()
Dim sheet_name, bookPath, fileName As String
Dim sheet_count,i As Integer
sheet_count = Sheets.Count
bookPath = ThisWorkbook.Path
   bookPath = bookPath + "\TEMP\"
    '判断文件目录是否存在
   If Dir(bookPath, 16) = Empty Then
    MkDir bookPath
   Else
    Kill bookPath & "\*.*"
   End If
For i = 1 To sheet_count

    sheet_name = Sheets(i).Name
    Sheets(sheet_name).Select
	'设置活动窗口为当前
	Set wkb = ActiveSheet
    fileName = bookPath + sheet_name + ".csv"

    On Error GoTo eh
    Const adTypeText = 2
    Const adSaveCreateOverWrite = 2

    Dim BinaryStream
    Set BinaryStream = CreateObject("ADODB.Stream")
    BinaryStream.Charset = "UTF-8"
    BinaryStream.Type = adTypeText
    BinaryStream.Open

    For r = 1 To wkb.UsedRange.Rows.Count
    s = ""
    c = 1
	While c <= wkb.UsedRange.Columns.Count
	If c < wkb.UsedRange.Columns.Count Then
     s = s & wkb.Cells(r, c).Value & ","
	Else
	 s = s & wkb.Cells(r, c).Value
	End if
    c = c + 1
    Wend
    BinaryStream.WriteText s, 1
    Next r

    BinaryStream.SaveToFile fileName, adSaveCreateOverWrite
    BinaryStream.Close
eh:
Next
Sheets(1).Select
MsgBox "CSV generated successfully"
End Sub

完美运行