• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

xml olusturmada sorun

Katılım
2 Aralık 2006
Mesajlar
32
Excel Vers. ve Dili
Excel XP, Türkçe
Sub XML_OLUSTUR()

'-----------------------------------------------
' XML_OLUSTUR Macro Yazan Mehmet Emin TATLI
'
' -----------------------------------------------

Sheets("XML").Select
Cells.Select
Selection.ClearContents
Range("A1").Select
Sheets("BILGILER").Select
Range("A2").Select
Sheet2.Cells(1, 1).Value = "<?xml version=""1.0"" encoding=""windows-1254""?>"
Sheet2.Cells(2, 1).Value = "<DocumentElement>"

S = 3
For K = 2 To Sheet1.Range("A2").CurrentRegion.Rows.Count
Sheet2.Cells(S + 0, 1).Value = "<GirisBildirimi>"
Sheet2.Cells(S + 1, 1).Value = " <CA_TC>" + Sheet1.Cells(K, 1) + "</CA_TC>"
Sheet2.Cells(S + 2, 1).Value = " <CA_AdSoyad>" + Sheet1.Cells(K, 2) + "</CA_AdSoyad>"
Sheet2.Cells(S + 3, 1).Value = " <CA_Baba>" + Sheet1.Cells(K, 3) + "</CA_Baba>"
Sheet2.Cells(S + 4, 1).Value = " <CA_Dyeri>" + Sheet1.Cells(K, 4) + "</CA_Dyeri>"
Sheet2.Cells(S + 5, 1).Value = " <CA_Dtrh>" + Sheet1.Cells(K, 5).Text + "00:00:00+02:00</CA_Dtrh>"
Sheet2.Cells(S + 6, 1).Value = " <CA_Medeni>" + Sheet1.Cells(K, 6) + "</CA_Medeni>"
Sheet2.Cells(S + 7, 1).Value = " <CA_Uyrugu>" + Sheet1.Cells(K, 7) + "</CA_Uyrugu>"
Sheet2.Cells(S + 8, 1).Value = " <CA_Il>" + Sheet1.Cells(K, 8) + "</CA_Il>"
Sheet2.Cells(S + 9, 1).Value = " <CA_Ilce>" + Sheet1.Cells(K, 9) + "</CA_Ilce>"
Sheet2.Cells(S + 10, 1).Value = " <CA_BckKoy>" + Sheet1.Cells(K, 10) + "</CA_BckKoy>"
Sheet2.Cells(S + 11, 1).Value = " <CA_PassTrhSay>" + Sheet1.Cells(K, 11) + "</CA_PassTrhSay>"
Sheet2.Cells(S + 12, 1).Value = " <CA_IkaTezSay>" + Sheet1.Cells(K, 12) + "</CA_IkaTezSay>"
Sheet2.Cells(S + 13, 1).Value = " <CA_OIAdi>" + Sheet1.Cells(K, 13) + "</CA_OIAdi>"
Sheet2.Cells(S + 14, 1).Value = " <CA_OIYeri>" + Sheet1.Cells(K, 14) + "</CA_OIYeri>"
Sheet2.Cells(S + 15, 1).Value = " <CA_YaptigiIs>" + Sheet1.Cells(K, 15) + "</CA_YaptigiIs>"
Sheet2.Cells(S + 16, 1).Value = " <CA_Adres>" + Sheet1.Cells(K, 16) + "</CA_Adres>"
Sheet2.Cells(S + 17, 1).Value = " <CA_AyrilisTrh></CA_AyrilisTrh>"
Sheet2.Cells(S + 18, 1).Value = " <CA_IsBar>" + Sheet1.Cells(K, 18) + "</CA_IsBar>"
Sheet2.Cells(S + 19, 1).Value = " <CA_BasTrh>" + Sheet1.Cells(K, 19).Text + "00:00:00+02:00</CA_BasTrh>"
Sheet2.Cells(S + 20, 1).Value = " </GirisBildirimi>"
S = S + 21
Next K
Sheet2.Cells(S, 1).Value = "</DocumentElement>"
MsgBox ("Makronun calismasi bitti." + Chr(13) + Chr(13) + "Simdi XML sayfasinda olusturulan bu bilgileri bir metin editorune kopyalayip yapistirin ve XML dosyasi olarak kayit edin." + Chr(13) + Chr(13) + "Kayit ettiginiz dosyayi Emniyetin sayfasindan kullanici adi ve sifrenizi kullanip, toplu ise giris bildirimi yapabilirsiniz.")

MsgBox "Dosya Kaydediliyor"

Sheets("XML").Select
Range("A2").Select

ChDir "C:\Users\HP8\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\EGMKMLK\KmlkBldrm.xml", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
Sheets("BILGILER").Select
Range("A2").Select

ActiveWorkbook.SaveAs Filename:= _
"C:\EGMKMLK\Emniyet Kimlik Bidirim Xml Oluştur.xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

End Sub
 
Geri
Üst