Klasör yolu açma, Seçilen dosyadan veri çekme.

[chngrcn]

Hayırlı günler,

ekteki dosyada klasör içindeki çalışmada butona tıklandığında klasör yolunu açacak, ve ilgili klasörden xml dosyasını seçtiğimizde,

xml içindeki veriyi a1 hücresinden başlayıp veriyi çekecek..

yardımlarınız için teşekkürler..

https://upterabit.com/Ulz/yeni.rar

 

[Zeki Gürsoy]

XML dosyasını Excel ile doğrudan açabilirsiniz. Tablo şeklinde ekrana gelecektir.

"Aç" komutunda dosya türünü "XML dosyaları" seçin.

 

[chngrcn]

Zeki hocam İlginiz için teşekkür ederim. Lakin bunu makro ile yapmak istiyorum. Buton ile klasör yolu açılacak ve xml dosyayı seçtiğimde veriyi çekecek.
Kod hakkında yardımlarınızı rica ediyorum. Saygılar

 

[Zeki Gürsoy]

Dosyanız ekte..

[SIZE=2]Sub xmlAl()
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
    fd.Filters.Clear
    fd.Filters.Add "XML Dosyaları (*.xml)", "*.xml", 1    
    ret = fd.Show
    
    If Not ret = -1 Then Exit Sub
    
    fn = fd.SelectedItems(1)
    
    Set doc = CreateObject("msxml2.domdocument")
    
    doc.async = False
    doc.Load fn
    
    Set col = doc.SelectNodes("//catalog/book")
    
    [a1] = "id"
    [a1].Font.Bold = True
    
    For n = 0 To col(i).ChildNodes.Length - 1
        Cells(1, n + 2) = col(i).ChildNodes(n).nodeName
        Cells(1, n + 2).Font.Bold = True
    Next
    
    For i = 0 To col.Length - 1
        Cells(i + 2, "a") = col.Item(i).Attributes.getNamedItem("id").Text

        For j = 0 To col(i).ChildNodes.Length - 1
            Cells(i + 2, j + 2) = col(i).ChildNodes(j).Text
        Next

        Rows(i + 2).EntireRow.AutoFit
        Columns("A:" & Chr(col(i).ChildNodes.Length + 64)).EntireColumn.AutoFit
    Next
End Sub[/SIZE]

 

[chngrcn]

Sub xmlAl()
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
    fd.Filters.Clear
    fd.Filters.Add "XML Dosyaları (*.xml)", "*.xml", 1
    fd.FilterIndex = 3
    ret = fd.Show
    
    If Not ret = -1 Then Exit Sub
    
    fn = fd.SelectedItems(1)
    
    Set doc = CreateObject("msxml2.domdocument")
    
    doc.async = False
    doc.Load fn
    
    Set col = doc.SelectNodes("//catalog/book")
    
    [a1] = "id"
    [a1].Font.Bold = True
    
   [COLOR="Red"] For n = 0 To col(i).ChildNodes.Length - 1[/COLOR]
        Cells(1, n + 2) = col(i).ChildNodes(n).nodeName
        Cells(1, n + 2).Font.Bold = True
    Next
    
    For i = 0 To col.Length - 1
        Cells(i + 2, "a") = col.Item(i).Attributes.getNamedItem("id").Text

        For j = 0 To col(i).ChildNodes.Length - 1
            Cells(i + 2, j + 2) = col(i).ChildNodes(j).Text
        Next

        Rows(i + 2).EntireRow.AutoFit
        Columns("A:" & Chr(col(i).ChildNodes.Length + 64)).EntireColumn.AutoFit
    Next
End Sub

zeki hocam, başka bir xml dosyası denediğimde kırmızı ile işaretlediğim satırda hata veriyor. ekteki resimde ki hatayı veriyor... bir bakmanız mümkün mü acaba ? hayırlı geceler..

 

[Zeki Gürsoy]

İkinci xml farklı mı? Farklıysa onu da görmeliyim.

Mevcut durumda "catalog" düğümü altında "book" arıyor. Farklıysa hata olması normaldir.

 

[chngrcn]

Ne tür xml olursa olsun dış veri al seçeneğindeki gibi xml'den veri al dediğimizde tüm tabloları ile birlikte nasıl geliyorsa verilerin tümünü getirsin.. tabi bunu makro ile yapmak istiyorum.. klasör yolu açma ve xml dosyası seçildikten sonra program hiç bir soru sormadan direkt tabloları ve veriyi çeksin getirsin..

örneğin;

 ActiveWorkbook.XmlImport URL:= _
        "C:\Users\NADAS\Desktop\yeni\Liste_2017.xml", ImportMap:= _
        Nothing, Overwrite:=True, Destination:=Range("$A$1")

gibi.. sizin kodunuzla nasıl harmanlarız bunu ?

 

[chngrcn]

Sub xmlAl()
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
    fd.Filters.Clear
    fd.Filters.Add "XML Dosyaları (*.xml)", "*.xml", 1
    fd.FilterIndex = 3
    ret = fd.Show
    
    If Not ret = -1 Then Exit Sub
    
    fn = fd.SelectedItems(1)
    
    Set doc = CreateObject("msxml2.domdocument")
    
    doc.async = False
    doc.Load fn
    
    [COLOR="Red"] ActiveWorkbook.XmlImport URL:= _
        fn, ImportMap:= _
        Nothing, Overwrite:=True, Destination:=Range("$A$1")[/COLOR]
    
'    Set col = doc.SelectNodes("//catalog/book")
    
'    [a1] = "id"
'    [a1].Font.Bold = True
'
'    For n = 0 To col(i).ChildNodes.Length - 1
'        Cells(1, n + 2) = col(i).ChildNodes(n).nodeName
'        Cells(1, n + 2).Font.Bold = True
'    Next
'
'    For i = 0 To col.Length - 1
'        Cells(i + 2, "a") = col.Item(i).Attributes.getNamedItem("id").Text
'
'        For j = 0 To col(i).ChildNodes.Length - 1
'            Cells(i + 2, j + 2) = col(i).ChildNodes(j).Text
'        Next
'
'        Rows(i + 2).EntireRow.AutoFit
'        Columns("A:" & Chr(col(i).ChildNodes.Length + 64)).EntireColumn.AutoFit
'    Next
End Sub

Zeki hocam, kırmızı ile boyadığım kısıma koyduğum kod ile işi çözdüm.. Lakin sizin ilk yaptığınız örnekte tablosuz, renksiz geldiği şekilde gelmesini istiyorum.. sadece yazıların yalın hali ile gelsin.. bu şekilde renkli tablo halinde geliyor.. bunu sağlamanız mümkünmü ?

 

[Zeki Gürsoy]

Bunu kullanın.

[SIZE=2]Sub xmlAl()
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
   
    fd.Filters.Clear
    fd.Filters.Add "XML Dosyaları (*.xml)", "*.xml", 1
    ret = fd.Show
    
    If Not ret = -1 Then Exit Sub
    
    fn = fd.SelectedItems(1)    
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   [/SIZE]
[SIZE=2][SIZE=2]    Set wb = Workbooks.Add[/SIZE]     
    wb.XmlImport fn, Nothing, True, wb.Sheets(1).Range("$A$1")
    
    wb.Sheets(1).[a1].CurrentRegion.Copy
    
    ThisWorkbook.ActiveSheet.[a1].PasteSpecial xlPasteValues
    
    wb.Close False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub[/SIZE]