Create CSV files that support Arabic or UTF-8

[YasserKhalil]

Hello everyone
I have this code that works well on my device

Code: Select all

Sub Test()
    Dim v, rng As Range, c As Range, coll As Collection, myKey As String, sPath As String, FileName As String, sNationality As String, csvContent As String, lr As Long, f As Long
    Application.ScreenUpdating = False
        lr = shDB.Cells(shDB.Rows.Count, "S").End(xlUp).Row
        Set rng = shDB.Range("S2:S" & lr)
        Set coll = New Collection
        On Error Resume Next
            For Each c In rng
                myKey = shDB.Cells(c.Row, "S").Value & "_" & shDB.Cells(c.Row, "T").Value
                coll.Add myKey, CStr(myKey)
            Next c
        On Error GoTo 0
        sPath = ThisWorkbook.Path & "\"
        For Each v In coll
            FileName = sPath & v & ".csv"
            f = FreeFile
            Open FileName For Output As f
            Print #f, "Name,Nationality,Email,Password"
            For Each c In rng
                If shDB.Cells(c.Row, "S").Value & "_" & shDB.Cells(c.Row, "T").Value = v Then
                    Select Case shDB.Cells(c.Row, "H").Value
                        Case 1: sNationality = "مصر"
                        Case 102: sNationality = "ليبيا"
                        Case Else: sNationality = Empty
                    End Select
                    csvContent = shDB.Cells(c.Row, "D").Value & "," & sNationality
                    Print #f, csvContent
                End If
            Next c
            Close f
            If InStr(v, "_1") > 0 Then
                Name FileName As sPath & Replace(v, "_1", "_بنون") & ".csv"
            ElseIf InStr(v, "_2") > 0 Then
                Name FileName As sPath & Replace(v, "_2", "_بنات") & ".csv"
            End If
        Next v
    Application.ScreenUpdating = True
    MsgBox "CSV Files Created Successfully!", vbInformation
End Sub

the code splits data into csv files, when viewing the files on my device, they worked well and I can view the Arabic characters well. But when uploading the files to specific website, the website displays the data into unkwown characters for the arabic data.

[YasserKhalil]

I have solved it but welcome any ideas

Code: Select all

Option Explicit

Sub Test()
    Dim v, rng As Range, c As Range, coll As Collection, myKey As String, sPath As String, FileName As String, sNationality As String, csvContent As String, lr As Long, f As Long
    Application.ScreenUpdating = False
        Dim sFullPath As String
        lr = shDB.Cells(shDB.Rows.Count, "S").End(xlUp).Row
        Set rng = shDB.Range("S2:S" & lr)
        Set coll = New Collection
        On Error Resume Next
            For Each c In rng
                myKey = shDB.Cells(c.Row, "S").Value & "_" & shDB.Cells(c.Row, "T").Value
                coll.Add myKey, CStr(myKey)
            Next c
        On Error GoTo 0
        sPath = ThisWorkbook.Path & "\"
        For Each v In coll
        csvContent = vbNullString
         csvContent = "Name,Nationality,Email,Password"
            FileName = sPath & v & ".csv"
            'f = FreeFile
            'Open FileName For Output As f
            'Print #f, "Name,Nationality,Email,Password"
            For Each c In rng
                If shDB.Cells(c.Row, "S").Value & "_" & shDB.Cells(c.Row, "T").Value = v Then
                    Select Case shDB.Cells(c.Row, "H").Value
                        Case 1: sNationality = "مصر"
                        Case 102: sNationality = "ليبيا"
                        Case Else: sNationality = Empty
                    End Select
                    csvContent = csvContent & vbCrLf & shDB.Cells(c.Row, "D").Value & "," & sNationality
                    'Print #f, csvContent
                    
                    
                    
                End If
            Next c
            
            'Close f
            If InStr(v, "_1") > 0 Then
            sFullPath = sPath & Replace(v, "_1", "_بنون") & ".csv"
                'Name FileName As sPath & Replace(v, "_1", "_بنون") & ".csv"
            ElseIf InStr(v, "_2") > 0 Then
                'Name FileName As sPath & Replace(v, "_2", "_بنات") & ".csv"
                sFullPath = sPath & Replace(v, "_2", "_بنات") & ".csv"
            End If
            
            
            With CreateObject("ADODB.Stream")
        .Mode = 0
        .Type = 2
        .LineSeparator = -1
        .Charset = "UTF-8"
        .Open
        .WriteText csvContent
        .SaveToFile sFullPath, 2
        .Close
    End With

            

        Next v
    Application.ScreenUpdating = True
    MsgBox "CSV Files Created Successfully!", vbInformation
End Sub