Excel VBA - 导出到UTF-8

本文介绍了Excel VBA - 导出到UTF-8的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

我创建的宏工作正常，我只需要整理保存业务。现在我得到一个弹出窗口问我在哪里保存，但我希望它保存在一个默认名称和路径AND编码为UTF-8。

这是我使用的完整代码，底部保存了我假设的文档。

Public Sub ExportToTextFile（FName As String，Sep As String ，SelectionOnly As Boolean，AppendData As Boolean） Dim WholeLine As String Dim fnum As Integer 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 Dim teller As Integer 'Teller aangemaakt ter controle voor het aantal velden 'teller = 1 Application.ScreenUpdating = False 错误GoTo EndMacro： fnum = FreeFile 如果SelectionOnly = True然后与选择 StartRow = .Cells（1）.Row StartCol = .Cells（ 26）.Column EndRow = .Cells（.Cells.Count）.Row EndCol = .Cells（.Cells.Count）.Column 结束 Else With ActiveSheet.UsedRange StartRow = .Cells（1）.Row StartCol = .Cells（26）.Column EndRow = .Cells（.Cells.Count）.Row EndCol = .Cells（26）.Column 结束结束如果如果AppendData = True然后打开FName为附加访问写为#fnum Else 打开FName输出访问写入#fnum 结束如果对于RowNdx = StartRow To EndRow WholeLine = 对于ColNdx = StartCol To EndCol 如果Cells（RowNdx，ColNdx）.Value =然后 CellValue = Else CellValue = Cells（RowNdx，ColNdx）.Value End If WholeLine = WholeLine& CellValue& （$）打印#fnum，WholeLine '打印#fnum，teller， WholeLine 'teller = teller + 1 Next RowNdx EndMacro：错误GoTo 0 Application.ScreenUpdating = True 关闭#fnum End Sub Sub Dump4Mini（） Dim FileName As Variant Dim Sep As String FileName = Application.GetSaveAsFilename（InitialFileName：= Blank，filefilter：=Text（* .txt），*。txt）如果FileName = False然后退出Sub 结束如果 Sep =| 如果Sep = vbNullString然后退出Sub 结束If Debug.PrintFileName：& FileName，Separator：& Sep ExportToTextFile FName：= CStr（FileName），Sep：= CStr（Sep），SelectionOnly：= False，AppendData：= False End Sub pre>

解决方案

这是我用来传递http网页，它返回一个带有正确编码的字符串

 公共功能UTF8（ByVal http As Object）As String 
 Dim BinaryStream 
 
 Const adTypeBinary = 1 
 Const adTypeText = 2 
 Const adModeReadWrite = 3 
 
设置BinaryStream = CreateObject（ADODB.Stream）
 
使用BinaryStream 
 .Type = adTypeBinary 
 .Open 
 .Write http.responseBody 
 
'更改流类型到二进制
 .Position = 0 
 .Type = adTypeText 
 
'指定字符集对于源文本
'.Charset =iso-8859-1'unicode 
 .Charset =utf-8'或utf-16 
 
'打开流并从对象获取二进制数据
 UTF8 = .ReadText 
结束
 En d函数

其中 http 在这种情况下像设置http = CreateObject（Microsoft.XMLHTTP），但我相信你可以适应你的需要。

这可以与字符串一起使用并直接输出文本文件

  Option Explicit 
 
子测试）
 Dim filePath As String 
 Dim fileName As String 
 Dim charToEncode As String 
 Dim success As Boolean 
 
 filePath =C：\Users\\ 
 fileName =test.txt
 charToEncode =Télécom
 
 success = ConvertToUTF8thenSaveToFile（charToEncode，filePath，fileName）
 
如果成功则
 MsgBox（Success）
 Else 
 MsgBox（Failed）
如果
结束Sub 
 
函数ConvertToUTF8thenSaveToFile（ByVal charToEncode As String，_ 
 ByVal filePath As String，ByVal fileName As String）As Boolean 
 
 Dim fsT As O bject 
 Dim adodbStream As Object 
 
错误GoTo错误：
设置adodbStream = CreateObject（ADODB.Stream）
使用adodbStream 
 .Type = 2'流类型
 .Charset =utf-8'或utf-16等
 .Open 
 .WriteText charToEncode 
 .SaveToFile filePath& fileName，2'保存二进制数据到磁盘
结束
 
 ConvertToUTF8thenSaveToFile = True 
 
错误GoTo 0 
 
退出函数
 
错误：
 ConvertToUTF8thenSaveToFile = False 
 
结束功能

更新：以下代码已更新，以创建一个范围的分隔字符串，对字符串进行编码并保存到一个文件。

  Option Explicit 
 
 Sub test（）
 Dim filePath As String 
 Dim fileName As String 
 Dim charToEncode As String 
 Dim encodingType As String 
 Dim success As Boolean 
 Dim rngArray（）As Variant 
 
 
 filePath =C：\Users\ooo\Desktop\
 fileName =test.csv
 rngArray = Sheet1.Range（A1：E10000）。值
 encodingType =utf-8
 
 charToEncode = DelimitRange（rngArray）
 success = ConvertToUTF8thenSaveToFile（charToEncode，filePath，fileName，encodingType）
 
如果s uccess Then 
 MsgBox（Success）
 Else 
 MsgBox（Failed）
 End If 
 End Sub 
 
函数ConvertToUTF8thenSaveToFile ByVal charToEncode As String，_ 
 ByVal filePath As String，ByVal fileName As String，ByVal encodingCharSet As String）As Boolean 
 
 Dim fsT As Object 
 Dim adodbStream As Object 
 
错误GoTo错误：
设置adodbStream = CreateObject（ADODB.Stream）
使用adodbStream 
 .Type = 2'流类型
 .Charset = encodingCharSet '或utf-16 etc 
 .Open 
 .WriteText charToEncode 
 .SaveToFile filePath& fileName，2'保存二进制数据到磁盘
结束
 
 ConvertToUTF8thenSaveToFile = True 
 
错误GoTo 0 
 
退出函数
 
 Err：
 ConvertToUTF8thenSaveToFile = False 
 
结束函数
 
函数DelimitRange（ByVal XLArray As Variant）As String 
 Const delimiter As String =，
 Const lineFeed As String = vbCrLf 
 Const removeExisitingDelimiter As Boolean = True 
 Dim rowCount As Long 
 Dim colCount As Long 
 Dim tempString As String 
 
 
对于rowCount = LBound（XLArray，1）到UBound（XLArray，1）
对于colCount = LBound（XLArray，2）到UBound（XLArray，2）
 
如果removeExisitingDelimiter然后
 tempString = tempString& Replace（XLArray（rowCount，colCount），delimiter，vbNullString）
 Else 
 tempString = tempString& XLArray（rowCount，colCount）
 End If 
 
'不要向列结尾添加分隔符
如果colCount< UBound（XLArray，2）Then tempString = tempString&分隔符
 
下一个colCount 
 
'添加linefeed 
如果rowCount< UBound（XLArray，1）Then tempString = tempString& lineFeed 
 
下一行rowCount 
 
 DelimitRange = tempString 
 
结束函数

The macro I created works fine, I just need to sort out the saving business. Now I get a popup asking me where to save it, but I would like it to save it under a default name and path AND encoded in UTF-8.

This is my full code I use, the bottom part saves the document I presume.

Public Sub ExportToTextFile(FName As String, Sep As String, SelectionOnly As Boolean, AppendData As Boolean)
    Dim WholeLine As String
    Dim fnum As Integer
    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
    Dim teller As Integer
    'Teller aangemaakt ter controle voor het aantal velden
    'teller = 1

    Application.ScreenUpdating = False
On Error GoTo EndMacro:
    fnum = FreeFile
    If SelectionOnly = True Then
        With Selection
            StartRow = .Cells(1).Row
            StartCol = .Cells(26).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With
    Else
        With ActiveSheet.UsedRange
            StartRow = .Cells(1).Row
            StartCol = .Cells(26).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(26).Column
        End With

    End If
    If AppendData = True Then
        Open FName For Append Access Write As #fnum
    Else
        Open FName For Output Access Write As #fnum
    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 #fnum, WholeLine, ""
        'Print #fnum, teller, WholeLine, ""
        'teller = teller + 1

    Next RowNdx

EndMacro:
    On Error GoTo 0
    Application.ScreenUpdating = True
    Close #fnum
End Sub

Sub Dump4Mini()
    Dim FileName As Variant
    Dim Sep As String

    FileName = Application.GetSaveAsFilename(InitialFileName:=Blank, filefilter:="Text (*.txt),*.txt")

    If FileName = False Then
        Exit Sub
    End If
    Sep = "|"
    If Sep = vbNullString Then
        Exit Sub
    End If
    Debug.Print "FileName: " & FileName, "Separator: " & Sep
    ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), SelectionOnly:=False, AppendData:=False
End Sub

解决方案

This is what I use to pass http webpages and it returns a string with the correct encoding

Public Function UTF8(ByVal http As Object) As String
Dim BinaryStream

Const adTypeBinary = 1
Const adTypeText = 2
Const adModeReadWrite = 3

 Set BinaryStream = CreateObject("ADODB.Stream")

 With BinaryStream
    .Type = adTypeBinary
    .Open
    .Write http.responseBody

    'Change stream type To binary
    .Position = 0
    .Type = adTypeText

    'Specify charset For the source text
    '.Charset = "iso-8859-1" 'unicode
    .Charset = "utf-8" 'or utf-16

    'Open the stream And get binary data from the object
    UTF8 = .ReadText
End With
End Function

Where http in this case is something like Set http = CreateObject("Microsoft.XMLHTTP") but I'm sure you can adapt to fit your needs.

This works with strings and outputs text file directly

Option Explicit

Sub test()
Dim filePath As String
Dim fileName As String
Dim charToEncode As String
Dim success As Boolean

    filePath = "C:\Users\ooo\Desktop\"
    fileName = "test.txt"
    charToEncode = "Télécom"

    success = ConvertToUTF8thenSaveToFile(charToEncode, filePath, fileName)

    If success Then
        MsgBox ("Success")
    Else
        MsgBox ("Failed")
    End If
End Sub

Function ConvertToUTF8thenSaveToFile(ByVal charToEncode As String, _
    ByVal filePath As String, ByVal fileName As String) As Boolean

    Dim fsT As Object
    Dim adodbStream  As Object

    On Error GoTo Err:
    Set adodbStream = CreateObject("ADODB.Stream")
    With adodbStream
        .Type = 2 'Stream type
        .Charset = "utf-8" 'or utf-16 etc
        .Open
        .WriteText charToEncode
        .SaveToFile filePath & fileName, 2 'Save binary data To disk
    End With

    ConvertToUTF8thenSaveToFile = True

    On Error GoTo 0

    Exit Function

Err:
ConvertToUTF8thenSaveToFile = False

End Function

UPDATE: below code has been updated to create delimited string from a range, encode the string and save to a file.

Option Explicit

Sub test()
Dim filePath As String
Dim fileName As String
Dim charToEncode As String
Dim encodingType As String
Dim success As Boolean
Dim rngArray() As Variant


    filePath = "C:\Users\ooo\Desktop\"
    fileName = "test.csv"
    rngArray = Sheet1.Range("A1:E10000").Value
    encodingType = "utf-8"

    charToEncode = DelimitRange(rngArray)
    success = ConvertToUTF8thenSaveToFile(charToEncode, filePath, fileName, encodingType)

    If success Then
        MsgBox ("Success")
    Else
        MsgBox ("Failed")
    End If
End Sub

Function ConvertToUTF8thenSaveToFile(ByVal charToEncode As String, _
    ByVal filePath As String, ByVal fileName As String, ByVal encodingCharSet As String) As Boolean

    Dim fsT As Object
    Dim adodbStream  As Object

    On Error GoTo Err:
    Set adodbStream = CreateObject("ADODB.Stream")
    With adodbStream
        .Type = 2 'Stream type
        .Charset = encodingCharSet 'or utf-16 etc
        .Open
        .WriteText charToEncode
        .SaveToFile filePath & fileName, 2 'Save binary data To disk
    End With

    ConvertToUTF8thenSaveToFile = True

    On Error GoTo 0

    Exit Function

Err:
ConvertToUTF8thenSaveToFile = False

End Function

Function DelimitRange(ByVal XLArray As Variant) As String
Const delimiter As String = ","
Const lineFeed As String = vbCrLf
Const removeExisitingDelimiter As Boolean = True
Dim rowCount As Long
Dim colCount As Long
Dim tempString As String


    For rowCount = LBound(XLArray, 1) To UBound(XLArray, 1)
        For colCount = LBound(XLArray, 2) To UBound(XLArray, 2)

            If removeExisitingDelimiter Then
                tempString = tempString & Replace(XLArray(rowCount, colCount), delimiter, vbNullString)
            Else
                tempString = tempString & XLArray(rowCount, colCount)
            End If

            'Don't add delimiter to column end
            If colCount < UBound(XLArray, 2) Then tempString = tempString & delimiter

        Next colCount

        'Add linefeed
        If rowCount < UBound(XLArray, 1) Then tempString = tempString & lineFeed

    Next rowCount

    DelimitRange = tempString

End Function

这篇关于Excel VBA - 导出到UTF-8的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！