Export from Excel to Text file in UTF16 encoded

[xcelgeek]

Hi,

I am able to export the data from "Temporary Products" to text file called "Product Master.txt". I want to get this text file in UTF16 encoded format. Please help me.

I have assigned code to a button called "Prepare to Upload" button "Temporary Products" tab.

You can see the exported data has some question marks (???), as this is the foreign language in the "Temporary Tab". If I make it UTF16 encoded, it will be shown properly in text.

Here is the file -


https://skydrive.live.com/redir?resid=CF0E71ECBE7252C!108&authkey=!ACzI4Hn0E1uOrzQ

Regards,
Lucky

 

[Rick Rothstein]

This question was cross-posted here (where I am guessing my answer over there was not helpful)...

Export to Text in UTF16 encoded - Microsoft Community

 

[ZVI]

Hi & Welcome to the Board!

You can try the below code to save active sheet as Unicode text file.
The created TXT file can be loaded to notepad or to Excel without loosing of MultiByte symbols.

Sub SaveAsUnicode()
  Dim f As String, wb As Workbook
  Application.ScreenUpdating = False
  Set wb = ActiveWorkbook
  f = wb.Path & "\Product Master.txt"
  ActiveSheet.Copy
  With ActiveWorkbook
    .SaveAs f, xlUnicodeText, CreateBackup:=False
    .Close False
  End With
  wb.Activate
  Application.ScreenUpdating = False
End Sub

Let us know if it suits or not.

 

[xcelgeek]

Hi ZVI,

Your code works fine. But I am unable to use it in my code. Will you please help me accommodate it in my code - where I am converting a range in a text file along with Pipe Seperated value.

Here is my code -
**********
Sub ModifiedFinalSave()


Dim wb As Workbook
Dim ws As Worksheet


Set wb = ThisWorkbook
Set ws = wb.Worksheets("Temporary Products")


Application.ScreenUpdating = False


Dim fpath As String
username = Application.username


fpath = "C:\" & "Temporory Items_" & Format(Now, "DD_MMM_YY_HH_MM_SS")
MkDir fpath


ws.Select


Dim i As Long


i = ws.Cells(Rows.Count, "A").End(xlUp).Row


' Exports to PipeDel.txt file


Dim SrcRg As Range


Dim CurrRow As Range


Dim CurrCell As Range


Dim CurrTextStr As String


Dim ListSep As String


Dim DataTextStr As String


ListSep = "|"


Set SrcRg = ActiveSheet.Range("A10:Y" & i)


Open fpath & "\" & "Product Master.txt" For Output As #1


For Each CurrRow In SrcRg.Rows


CurrTextStr = ""


For Each CurrCell In CurrRow.Cells


CurrTextStr = CurrTextStr & CurrCell.Value & ListSep


Next


If Right(CurrTextStr, 1) = ListSep Then
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
End If


'Added next line to put | at end of each line


CurrTextStr = CurrTextStr


Print #1, CurrTextStr


Next


Close #1


End Sub
**********

Please let me know if you need any other information.

 

[ZVI]

Hi,
Try this instead:

Sub SaveRangeAsUTF16()
  ' ZVI-2013-06-16 http://www.mrexcel.com/forum/excel-questions/707325-export-excel-text-file-utf16-encoded.html
  ' Exports A10:Y(last row) to UTF-16 text file with "|" as a list separator
 
  Const ListSeparator As String = "|"
  Const LineSeparator As String = vbCrLf
  Const LastTitleCell As String = "Y10"
 
  Dim FileFolder As String, FileName As String
  Dim a()
  Dim ar() As String, ac() As String, txt As String
  Dim c As Long, cs As Long, r As Long, rs As Long
 
  FileFolder = "C:\Temporory Items_" & Format(Now, "DD_MMM_YY_HH_MM_SS")
  FileName = "Product Master.txt"
  MkDir FileFolder
 
  ' Copy range to array
  a() = Range(Cells(Rows.Count, "A").End(xlUp), LastTitleCell).Value
 
  ' Define the rows and columns count
  rs = UBound(a, 1)
  cs = UBound(a, 2)
 
  ' Prepare 1-D arrays for all rows and for each column
  ReDim ar(1 To rs)
  ReDim ac(1 To cs)
 
  ' Join data of each row
  For r = 1 To rs
    For c = 1 To cs
      ac(c) = Trim(a(r, c))
    Next
    ar(r) = Join(ac, ListSeparator) & LineSeparator
  Next
 
  ' Join data of all rows
  txt = Join(ar, ListSeparator) & LineSeparator
 
  ' Save as UTF-16
  With CreateObject("ADODB.Stream")
    .Type = 2
    .Mode = 3
    .Open
    .Charset = "utf-16"
    .WriteText txt
    .Position = 0
    .SaveToFile FileFolder & "\" & FileName, 2
    .Close
  End With
 
End Sub

Regards

 

[xcelgeek]

Thanks a lot ZVI ! This is what I was looking for. But there is one problem. This code puts pipe (|) in the starting of each row.

Lets say I have data in A1 to C2 cells then I would like my data to be shown something like this in the text file -

A1 Value|B1 Value|C1 Value
A2 Value|B2 Value|C2 Value

So in the beginning and end of the row there should not be pipe (|).

Please let me know if you need anything else from me.

Thanks a lot for your help.

 

[Rick Rothstein]

Thanks a lot ZVI ! This is what I was looking for. But there is one problem. This code puts pipe (|) in the starting of each row.

Lets say I have data in A1 to C2 cells then I would like my data to be shown something like this in the text file -

A1 Value|B1 Value|C1 Value
A2 Value|B2 Value|C2 Value

So in the beginning and end of the row there should not be pipe (|).

After a "fast look", try changing this line from ZVI's code...

  ' Join data of all rows
  txt = Join(ar, ListSeparator) & LineSeparator

to this

  ' Join data of all rows
  txt = Mid(Join(ar, ListSeparator), 2)

 

[ZVI]

Yea, I see my misprints, here is the fixed code:

Sub SaveRangeAsUTF16()
  ' ZVI-2013-06-16 http://www.mrexcel.com/forum/excel-questions/707325-export-excel-text-file-utf16-encoded.html
  ' Exports A10:Y(last row) to UTF-16 text file with "|" as a list separator
 
  Const ListSeparator As String = "|"
  Const LineSeparator As String = vbCrLf
  Const LastTitleCell As String = "Y10"
 
  Dim FileFolder As String, FileName As String
  Dim a()
  Dim ar() As String, ac() As String, txt As String
  Dim c As Long, cs As Long, r As Long, rs As Long
 
  FileFolder = "C:\Temporory Items_" & Format(Now, "DD_MMM_YY_HH_MM_SS")
  FileName = "Product Master.txt"
  MkDir FileFolder
 
  ' Copy range to array
  a() = Range(Cells(Rows.Count, "A").End(xlUp), LastTitleCell).Value
 
  ' Define the rows and columns count
  rs = UBound(a, 1)
  cs = UBound(a, 2)
 
  ' Prepare 1-D arrays for all rows and for each column
  ReDim ar(1 To rs)
  ReDim ac(1 To cs)
 
  ' Join data of each row
  For r = 1 To rs
    For c = 1 To cs
      ac(c) = Trim(a(r, c))
    Next
    ar(r) = Join(ac, ListSeparator)
  Next
 
  ' Join data of all rows
  txt = Join(ar, LineSeparator) & LineSeparator
 
  ' Save as UTF-16
  With CreateObject("ADODB.Stream")
    .Type = 2
    .Mode = 3
    .Open
    .Charset = "utf-16"
    .WriteText txt
    .Position = 0
    .SaveToFile FileFolder & "\" & FileName, 2
    .Close
  End With
 
End Sub

 

[xcelgeek]

Thanks a TON ZVI and Rick ! The code works like a charm. Thanks again

 

[ZVI]

Thanks for letting us know it works.
Cheers!