- Katılım
- 13 Ekim 2017
- Mesajlar
- 178
- Excel Vers. ve Dili
- 2003-tr
- Altın Üyelik Bitiş Tarihi
- 13/02/2019
Merhaba arkadaşlar;
Excel'den makro koduyla xml oluşturuyorum ama Türkçe karakterleri kod olarka gösteriyor. Replace ile değiştirip yapmak da istemiyorum. Kullandığım kod aşağıda. Önerilerinizi bekliyorum
Teşekkürler.
Excel'den makro koduyla xml oluşturuyorum ama Türkçe karakterleri kod olarka gösteriyor. Replace ile değiştirip yapmak da istemiyorum. Kullandığım kod aşağıda. Önerilerinizi bekliyorum
Teşekkürler.
Kod:
Sub MGS5_Outxml()
Dim txtname, yol, filename, subs, BOM As String
Dim son, isay, x, ix, xml, kvar As Long
Dim FSO, Out As Object
Dim ilerleme As Single
Set FSO = CreateObject("Scripting.FileSystemObject")
BOM = ""
son = Cells(1048576, 1).End(xlUp).Row
yol = Sayfa2.Range("A2")
'------------ Make folder--------------
kvar = FSO.FolderExists(yol)
If kvar <> True Then
FSO.CreateFolder yol
End If
'------------ pro ayarlar--------------
Application.ScreenUpdating = False
Application.DisplayAlerts = False
DoEvents ' userformun düzgün görünmesi için
'On Error Resume Next
'------------ karakter düzeltme--------------
Cells.Replace Chr(10), "
" ' satırbaşı xml koda dönüştür
Cells.Replace """", """ ' tırnak işareti xml koda dönüştür
Cells.Replace "…", "..." ' " karakteri
Cells.Replace "R&D", "R&D" ' & işaretini koda dönüştürür
Cells.Replace "Ar&Ge", "Ar&Ge" ' & işaretini koda dönüştürür
'------------ work--------------
For x = 2 To son
If txtname <> Range("A" & x - 1) Then
txtname = Range("A" & x)
filename = yol & "\" & txtname
Set Out = FSO.CreateTextFile(filename, True, False) '2.true ansi için
Out.WriteLine BOM & ("<?xml version=" & """" & "1.0" & """" & " encoding=" & """" & "utf-8" & """" & "?>")
Out.WriteLine ("<SubpFile xmlns:xsi=" & """" & "http://www.w3.org/2001/XMLSchema-instance" & """" & " xmlns:xsd=" & """" & "http://www.w3.org/2001/XMLSchema" & """" & ">")
Out.WriteLine (" <Entries>")
isay = Application.WorksheetFunction.CountIf(Range("A" & x & ":A" & son), txtname)
For ix = x To x + (isay - 1)
'If Range("G" & ix) <> "" Then
subs = Range("G" & ix)
'Else
'subs = Range("H" & ix)
'End If
Out.WriteLine (" <Entry Id=" & """" & Range("B" & ix) & """" & " Priority=" & """" & Range("C" & ix) & """" & " Flags=" & """" & Range("D" & ix) & """" & " Unknown=" & """" & Range("E" & ix) & """" & " AdditionalLength=" & """" & Range("F" & ix) & """" & ">")
Out.WriteLine (" <Lines>")
Out.WriteLine (" <Line Text=" & """" & subs & """" & ">")
Out.WriteLine (" <Timing Start=" & """" & Range("H" & ix) & """" & " End=" & """" & Range("I" & ix) & """" & " />")
Out.WriteLine (" </Line>")
Out.WriteLine (" </Lines>")
Out.WriteLine (" </Entry>")
Next ix
Out.WriteLine (" </Entries>")
Out.WriteLine ("</SubpFile>")
xml = xml + 1
End If
x = x + isay
Next x
'------------ END--------------
Cells.Replace "
", Chr(10) ' satırbaşı xml koda dönüştür
Cells.Replace """, """" ' tırnak işareti xml koda dönüştür
Cells.Replace "R&D", "R&D" ' & işaretini koda dönüştürür
Cells.Replace "Ar&Ge", "Ar&Ge" ' & işaretini koda dönüştürür
'--------------------------------------------------
Sayfa2.Range("B1").Value = xml
Sayfa2.Range("C1").Value = yol
End Sub
Son düzenleme: