XML'yi Excel ile açıp, Geri XML yapma (YARDIM)

[TanerSaydam]

Merhaba arkadaşlar;

Bir klasör içinde 10-15 tane xml dosyam var. Bu dosyalardan çeviri yapıyorum ama tek tek açıp çevirmek, onca kod arasından istediğimi bulmak zor oluyor. Ve dosya adları ve sayısı değişebiliyor. O yüzden istediğim şey excel'de IMPORT tuşuna basınca, belirttiğim klasördeki tüm XML'leleri aşağıdaki şemada açması ve EXPOT deyince geri orijinallerinin üstüne paketlemesi.

ŞEMA ŞU:

A B C D E
DOSYA ADI ID VALUE VALUE DOSYA KONUMU

XML'lelerin içinde ID ve VALUE değerleri var. Ama arada başka kodlarda var. Hem istediğim örnek excel dosyasını hemde xml'lelerden bir kaçtanesini aşağıya yükledim.

Ben bir şeyler denedim ama ilmim yetmedi. Ustalardan yardım bekliyorum. Teşekkürler şimdiden.


EDİT: Araştırmalarım ve eskiden bir abimden aldığım kodları derlemem sonucunda istediğim klasördeki tüm XML'leleri excel'de istediğim bir sayfaya aktarmayı başardım. O sayfadan da yukarıdaki formata uygun şekilde Sayfa1'e aktardım. Şimdi geri XML oluşturmayı deneyeceğim. Gelişmeleri editleyeceğim.

Sub From_XML_To_XL()
Sheets("Work").Select

Range("a:z").EntireRow.Delete
Dim fso As Object, ad As Object
Dim ds, dc, f, s, sayx, sn, SONA, SONB, SONC, uzantı, isim, bak 'kısa kodlar tanımlanıyor
yol = ThisWorkbook.Path & "\original\" 'bakacağı dosya konumu
bak = "xml" 'listeye eklenecek uzantıyı belirleme
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder(yol)
Set dc = f.Files
sayx = 1

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'On Error Resume Next
For Each dosya In dc
isim = dosya.Name 'sıradaki dosyanın adı
uzantı = Right(isim, 3) 'sıradaki dosyanın uzantısı
SONA = Cells(1048576, 3).End(xlUp).Row + 1

    If uzantı = bak Then
        ActiveWorkbook.XmlImport URL:=yol & isim, ImportMap:=Nothing, Overwrite:=False, Destination:=Range("B" & SONA)
        SONB = Cells(1048576, 3).End(xlUp).Row
            sn = 0
        SONA = Range("A" & Rows.Count).End(3).Row
        Range("A" & SONA + 1) = "DOSYA ADI"
        Range("A" & SONA + 2) = isim
        Range("A" & SONA + 2).Copy
        Range("A" & SONA + 3 & ":A" & SONB).PasteSpecial
        Application.CutCopyMode = False
        
        SONJ = Range("J" & Rows.Count).End(3).Row
        Range("J" & SONJ + 1) = "DOSYA KONUMU"
        Range("J" & SONJ + 2) = Left(dosya, Len(dosya) + (Len(isim) + 1))
        Range("J" & SONJ + 2).Copy
        Range("J" & SONJ + 3 & ":J" & SONB).PasteSpecial
                
        Application.CutCopyMode = False
        sayx = sayx + 1
    End If
Next
Columns("A:Z").EntireColumn.AutoFit
Rows.EntireRow.AutoFit
End Sub

Sub S1_Tasi()
'Work'deki değerleri Sayfa1'e taşır.
SONA = Sheets("Work").Range("A" & Rows.Count).End(3).Row

say = 2
For x = 2 To SONA
If Not Sheets("Work").Range("A" & x).Value = "DOSYA ADI" Then
    Sayfa1.Range("A" & say).Value = Sayfa3.Range("A" & x).Value
    Sayfa1.Range("B" & say).Value = Sayfa3.Range("B" & x).Value
    Sayfa1.Range("C" & say).Value = Sayfa3.Range("G" & x).Value
        If Sayfa1.Range("D" & say).Value = "" Then
        Sayfa1.Range("D" & say).Value = Sayfa3.Range("G" & x).Value
        End If
    Sayfa1.Range("E" & say).Value = Sayfa3.Range("J" & x).Value
    say = say + 1
End If
Next

'Sayfa1.Columns.EntireColumn.AutoFit
Sayfa1.Rows.EntireRow.AutoFit
End Sub

Sub XML_IN()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'On Error Resume Next

SONC = Sayfa1.Range("C" & Rows.Count).End(3).Row
Sayfa1.Range("A2:C" & SONC).ClearContents
Sayfa1.Range("E2:E" & SONC).ClearContents

Call From_XML_To_XL
Call S1_Tasi
Sayfa1.Select
MsgBox "Aktarım başarıyla tamamlandı", vbOKOnly + vbInformation, "BAŞARILI!"

End Sub

EDİT2: Yine bir örnek dosyadan ufak düzeltmeler ile XML'leleri geri paketlemeyi başardım. Sayfa1'de düzelttiğim satırları Sayfa3'deki yerlerine aktarıyor ve tırnak işareti gibi verileri kod haline getirip Sayfa2!A2'de belirttiğim konuma XML olarak kaydediyor.

Sub S1_den_Aktar()
SONA = Sayfa1.Range("A" & Rows.Count).End(3).Row
say = 2
    For x = 2 To SONA
    If Sayfa3.Range("B" & x).Value = Sayfa1.Range("B" & say).Value Then
       Sayfa3.Range("G" & x).Value = Sayfa1.Range("D" & say)
       say = say + 1
    End If
    Next
End Sub

Sub XML_OUT()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'On Error Resume Next

Call S1_den_Aktar
Call MGS5_Outxml
Sayfa1.Select


MsgBox Sayfa2.Range("C1").Value & " konumuna " & Sayfa2.Range("B1").Value & " xml dosyası oluşturuldu.", vbInformation, "BAŞARILI!"
Application.ScreenUpdating = 1
Sayfa2.Range("B1").Value = ""
Sayfa2.Range("C1").Value = ""
End Sub


Sub MGS5_Outxml()
Sayfa3.Select
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
'------------ 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>")
            Range("B" & ix).Interior.ColorIndex = 35
        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

Sayfa2.Range("B1").Value = XML
Sayfa2.Range("C1").Value = yol
End Sub