Türkçe karakter sorunu

[mtbi00]

Merhaba,

Excel dosyama VBA kullanarak TXT dosyasından veri almak istiyorum. Aşağıdaki kodla TXT dosyasını seçerek excele aktarabiliyorum ama Türkçe karakterlerde sorun oluyor. TXT dosyasının içindeki Türkçe karakterler bozuk olarak excele geliyor. Yardımlarınız için teşekkür ederim.


Private Sub CommandButton5_Click()
fName = Application.GetOpenFilename("Text Files,*.txt")
If fName = False Then Exit Sub
Set s1 = ThisWorkbook.Worksheets.Add
s1.Name = "DENEME"
With s1.QueryTables.Add(Connection:="TEXT;" & fName, Destination:=s1.Range("A1"))
.TextFilePlatform = 28599
.Refresh (False)
End With
End Sub


TXT Dosyasındadaki bilgi : DENEME,DENEME İNŞ.PROJE MÜŞAVİRLİK A.Ş.,NECATİBEY CAD.OLUK İŞ MERKEZİ NO:199/6,SIHHIYE/ÇANKAYA/ANKARA,MALTEPE VD,1234567890

Excel Dosyasındaki görünümü : DENEME,DENEME Ä°NÅ.PROJE MÃÅAVÄ°RLÄ°K A.Å.,NECATÄ°BEY CAD.OLUK Ä°Å MERKEZÄ° NO:199/6,SIHHIYE/ÃANKAYA/ANKARA,MALTEPE VD,1234567890

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki satırı değiştirin.

.TextFilePlatform = 28599

.TextFilePlatform = 65001

 

[mtbi00]

Merhaba.

Aşağıdaki satırı değiştirin.

.TextFilePlatform = 28599

.TextFilePlatform = 65001

İlginizden dolayı çok teşekkür ederim. Sorun çözüldü. İyi günler.

 

[sarigozoglu]

Merhabalar,
Problem aynı olduğu için yeniden konu açmak istemedim.
Bende bir başka bir uygulama tarafından üretilen TXT dosyasından veri çekiyorum.
Gelen TXT dosyasının tipi BOM ile UTF-8. Dosya türünü ANSI yaparsam sorun yok.
Ancak BOM ile UTF-8 ile çekersem Türkçe karakter sorunu yaşıyorum. Dosyayı her seferinde ANSI yapmak mümkün değil.
Örneğin Çarşaf yerine "ÇarÅŸaf" geliyor.

Kodlarım aşağıdaki gibidir. Desteğiniz için teşekkür ederim

Sub txt()
Dim deg1, k As Integer, a As String, sat As Long, sut As Integer
Dim deg2, m
Application.ScreenUpdating = False
Set S1 = Sheets("VERİ")
Set S2 = Sheets("PARAMETRE")
S1.Range("A2:U65536").ClearContents
sat = 2
DYeri = CreateObject("Wscript.Shell").specialfolders("Desktop")
DAdi = S2.Range("B7")
Dosya = DYeri & "\" & DAdi

If Dosya = False Then Exit Sub

Open (Dosya) For Input As #1
Do While Not EOF(1)
Line Input #1, a
m = m + 1
If m > 1 Then
deg1 = Split(a, Chr(10))
sut = 1
For k = LBound(deg1) To UBound(deg1)
If k = 0 Then
deg2 = Split(deg1(k), "|")
For j = LBound(deg2) To UBound(deg2)
If IsNumeric(Trim(deg2(j))) Then S1.Cells(sat, sut).Value = Trim(deg2(j)) * 1 Else S1.Cells(sat, sut).Value = Trim(deg2(j))
sut = sut + 1
Next
Else
S1.Cells(sat, sut).Value = deg1(k)
sut = sut + 1
End If

Next
sat = sat + 1
End If
Loop
Close #1

Application.ScreenUpdating = True
MsgBox "İşlem tamamdır." & vbLf, vbOKOnly + vbInformation, "UYARI"
End Sub

 

[Haluk]

Örnek Text dosyası var mı?

.

 

[sarigozoglu]

Örnek Text dosyası var mı?

.

Ektedir.

 

[Haluk]

Bu kodla karakterler düzgün şekilde alınabiliyor..... ihtiyacınıza göre düzenlersiniz.

Sub Test()
    'Haluk - 10/11/2019
    'sa4truss@gmail.com
    '
    Dim MyFile As Variant
    Dim myArr As Variant
    Dim adoStream As Object
    Dim i As Integer, j As Integer
    
    Const adTypeText = 2
    
    Range("A1:C" & Rows.Count) = ""
    
    MyFile = Application.GetOpenFilename("Text Files, *.txt", , "Dosya seçin...")
    If MyFile = False Then Exit Sub

    Set adoStream = CreateObject("ADODB.Stream")

    adoStream.Charset = "UTF-8"
    adoStream.Type = adTypeText

    adoStream.Open
    adoStream.LoadFromFile (MyFile)

    strFile = adoStream.ReadText(FileLen(MyFile))
    
    myArr = Split(strFile, vbCrLf)
    
    For i = LBound(myArr) To UBound(myArr)
        j = j + 1
        Cells(j, 1) = myArr(i)
    Next
    
    adoStream.Close
    Set adoStream = Nothing
    
    Columns.AutoFit
End Sub

.

 

[sarigozoglu]

Çok teşekkür ederim uyarlayacağım kendime, sekmeli metin ayrımı ile sütunlara da ayırmam gerekiyor

 

[Haluk]

Metinlerin ayrıştırılmasını halledersiniz artık...

.