Exporting utf-8 from Excel

Eben

New Member
Joined
Dec 14, 2020
Messages
2
Office Version
  1. 365
I need some help figuring out how to export data from column-B for each filename in column-A. At the moment It will only export last row of Column-B for each filename in column-A.
AB
Filename-1Data-a
Filename-1Data-b
Filename-1Data-c
Filename-2Data-e
Filename-2Data-f

VBA Code:
Option Explicit
Sub WriteUtf8()
Dim filePath As String
Dim charToEncode As String
Dim success As Boolean
Dim r As Long
Dim oldFn As String
Dim currFn As String
Dim lastRow As Long

        lastRow = Cells(Rows.Count, "A").End(xlUp).row

        For r = 1 To lastRow
            currFn = Cells(r, "A").Value
        If currFn <> oldFn Then
            oldFn = currFn
        
            If r > 1 Then Close
            
    filePath = ThisWorkbook.Path & "\html\" & currFn & ".html"
    
         End If
      
            charToEncode = Cells(r, "B").Value
            success = ConvertSave(charToEncode, filePath)
       Next
    Close
       
    If success Then
        MsgBox ("Done")
    Else
        MsgBox ("Error")
    End If
    

End Sub


Function ConvertSave(ByVal charToEncode As String, _
    ByVal filePath 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 
        .Charset = "utf-8" 
        .Open
        .WriteText charToEncode
        .SaveToFile filePath, 2 
    End With

    ConvertSave = True

    On Error GoTo 0

    Exit Function

Err:
ConvertSave = False

End Function
 

Some videos you may like

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
Hi Eben, welcome to MrExcel.

To get straight to the point and to be clear, I am not familiar with ADO, however .... from your code it becomes clear to me what causes the effect as you described.
For every row in your sheet the ConvertSave function procedure is invoked. That function creates on every run a new stream object. Each of those stream objects cannot be aware of the existence of the other stream objects. If a certain file name is used for more than one stream object, the stream which was written to last remains.
Long story short, if the linked file name doesn't change, data will be overwritten.

While it would have been possible to rewrite your ConvertSave function, I chose to work around your problem by deploying a class. Hopefully this is of some help.

This code goes in a standard module:
VBA Code:
Sub WriteUtf8()
    
    Dim oADO        As clsADODBStream
    Dim ErrMsg      As VbMsgBoxResult
    Dim rng         As Range
    Dim c           As Range
    Dim sFile       As String
    Dim bFirstTurn  As Boolean
    
    On Error GoTo Sub_ERR

    With ActiveSheet
        Set rng = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp))
    End With
 
    bFirstTurn = True
    For Each c In rng
        sFile = ThisWorkbook.Path & "\html\" & c.Value & ".html"
        If Not bFirstTurn Then
            If StrComp(c.Value, c.Offset(-1, 0).Value, vbTextCompare) <> 0 Then
                oADO.SaveAndClose
                Set oADO = New clsADODBStream
                oADO.OpenStream sFile
            End If
        Else
            Set oADO = New clsADODBStream
            oADO.OpenStream sFile
            bFirstTurn = False
        End If
        oADO.WriteText c.Offset(0, 1).Value
    Next c
    oADO.SaveAndClose
    Set oADO = Nothing
    
    If ErrMsg = 0 Then
        MsgBox "Done"
    End If
    Exit Sub

Sub_ERR:
    ErrMsg = MsgBox("Error " & err.Number & vbNewLine & _
                    "Source: " & err.Source & vbNewLine & _
                    "Description: " & err.Description, vbCritical + vbAbortRetryIgnore, "WriteUtf8")
    err.Clear
    If ErrMsg = vbAbort Then
        Exit Sub
    ElseIf ErrMsg = vbRetry Then
        Resume
    ElseIf ErrMsg = vbIgnore Then
        Resume Next
    End If
End Sub

This code goes in a class module, which should be renamed to clsADODBStream:
VBA Code:
Option Explicit

Private oStream         As Object
Private sFullFileName   As String

Private Sub Class_Terminate()
    Set oStream = Nothing
End Sub

Public Sub OpenStream(ByVal argFileName As String)
    sFullFileName = argFileName
    Set oStream = CreateObject("ADODB.Stream")
    With oStream
        .Type = 2
        .Charset = "utf-8"
        .Open
    End With
End Sub

Public Sub WriteText(ByVal argTxt As String)
    If Not oStream Is Nothing Then
        oStream.WriteText argTxt
    End If
End Sub

Public Sub SaveAndClose()
    Dim lErr As Long
    If Not oStream Is Nothing Then
        On Error Resume Next
        oStream.SaveToFile sFullFileName, 2
        lErr = err.Number
        oStream.Close
        On Error GoTo 0
        If lErr > 0 Then
            err.Raise vbError + lErr, "ADODBStream Class", "Saving to file failed:" & vbNewLine & sFullFileName
        End If
        Set oStream = Nothing
    End If
End Sub
 
  • Like
Reactions: yky
Solution

Eben

New Member
Joined
Dec 14, 2020
Messages
2
Office Version
  1. 365
Amazing! That is exactly what I was looking for.
It was so nice of you to reply and find the work around.
I am so happy to find such a welcoming community.
Thank you so much for taking the time, I really appreciate it.

Happy Holidays and God Bless!
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
You are welcome. Thanks for letting me know and same wishes to you!
 

Watch MrExcel Video

Forum statistics

Threads
1,126,925
Messages
5,621,631
Members
415,848
Latest member
LCC

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top