VBA excel Export XML

[ Davorenko @ 30.06.2020. 08:25 ] @

Može li mi neko pomoći,

Imam jednu tabelu napravljernu prema XML shemi,

trebao bih te podatke iz te tabele preko VBa coda izvesti u xml fajl. kojem se treba spremiti na određenu lokaciju, pod određenim nazivom

Pozz

[ pera68 @ 30.06.2020. 08:37 ] @

Code:

     dim adresa as string
     adresa = Worksheets("list1").Range("A1").Value
     Folder = Dir(adresa, vbDirectory)
     If (Folder = "") Then MkDir (adresa)
     ActiveWorkbook.SaveCopyAs adresa & "Naziv fajla " & " - " & ActiveWorkbook.Worksheets("list1").Range("A2").Value & ".xml"

[ Davorenko @ 30.06.2020. 09:39 ] @

U prilogu se nalazi tabela u koju sam napravio makro

Imam problem kada stavim raspon a1:T1, neće da izvese u ucm

druga stvar je trebalo bi da se xml snmi pod nazivom prve kolone u folder c:\adresa

[ Jpeca @ 30.06.2020. 17:55 ] @

U slučaju da imaš određenu šemu možeš snimiti XML sa metodom SaveAsXMLData

Na osnovu onoga što si napisao moglo bi nešto ovako:

Code:
Sub SnimiXML()

    Const fpath As String = "C:\adresa" ' folder u koji se snima
    Dim file As String
    Dim sh As Worksheet
    ' Startovati sa aktivnog lista
    Set sh = ActiveSheet

    file = sh.Range("A1").Value 'file u koji se snima
    folder = Dir(fpath, vbDirectory)
    ' Ako ne postoji folder kreirati
    If (folder = "") Then MkDir (fpath)
    ' Schema
    Dim objMapToExport As XmlMap
    Set objMapToExport = ActiveWorkbook.XmlMaps("RacunZahtjev_Map")

    If objMapToExport.IsExportable Then
      ActiveWorkbook.SaveAsXMLData fpath & "\" & file & ".xml", objMapToExport
    Else
        MsgBox "Neodgovarajuća šema za eksport XML " & objMapToExport.Name
    End If

End Sub

[ Davorenko @ 30.06.2020. 19:04 ] @

Hvala Jpeca, te je to sto sam trazio

LP

[ donbozone @ 28.08.2022. 23:53 ] @

Ako mogu da oživim temu pošto mi je potrebno nešto slično, ali sa još par koraka.

Imam source tabelu sa podacima koje treba da exportujem u xml, nekih 2000+ redova.

Xml šema je mapirana i može da se exportuje, tako da ostaje da se iz source tabele prekopira samo jedno polje, ključ (ostala polja popunjavam preko njega).

Jedan red sadrži sve podatke koji mi trebaju za export, tako da treba da bude jedan red=jedan xml.

Makro bi trebalo da radi sledeće:

1. Kopira vrednost iz source tabele (ključ) sa sheet-a 1 od ćelije AS4 u ćeliju F2 na sheet-u 2 (na ovaj način imam popunjena sva i polja i spreman export)
2. Pokreće export u xml
3. U putanju ubacuje vrednost iz ćelije I2 sa Sheet-a 2 gde sam uslovno upisao putanju
4. Ubacuje naziv fajla iz ćelije I3 sa Sheet-a 2 gde sam uslovno upisao ime
5. Exportuje xml
6. Kreće novi krug kopiranjem ćelije AS5 sa prvog Sheet-a ponovo u F2 na drugom itd...
7. Završava kada u koloni AS više nema vrednosti

Nadam se da će neko uspeti da doradi ovo sto je JPeca napravio.

Hvala

[ Jpeca @ 05.09.2022. 09:01 ] @

Koliko sam razumeo ti nemaš problem sa export u xml nego treba neka petlja u kojoj se poziva SnimiXML sa paremetrom fpath i file (ime fajla)
Izmeni SnimiXML tako da umesto prve dve linije prosleđuješ parametre

Napravi poziv SnimiXML unutar petlje po svim redovima iz Sheet1 od AS4 do kraja. Bilo bi lakše da se postavio primer, ali ovako napamet nešto kao

Code:
Option Explicit
Sub SnimiXML(fpath As String, fname As String)

    Dim sh As Worksheet
    ' Startovati sa aktivnog lista
    Set sh = ThisWorkbook.ActiveSheet
    Dim folder As Variant
    folder = Dir(fpath, vbDirectory)
    ' Ako ne postoji folder kreirati
    If (folder = "") Then MkDir (fpath)
    ' Schema
    Dim objMapToExport As XmlMap
    Set objMapToExport = ActiveWorkbook.XmlMaps("RacunZahtjev_Map")

    If objMapToExport.IsExportable Then
      ActiveWorkbook.SaveAsXMLData fpath & "\" & fname & ".xml", objMapToExport
    Else
        MsgBox "Neodgovarajuća šema za eksport XML " & objMapToExport.Name
    End If

End Sub

Sub Izvrsi()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim startRw As Long, endRw As Long, rw As Long
  Dim fpath As String, fname As String

  Set sh1 = ThisWorkbook.Sheets("Sheet1")
  Set sh2 = ThisWorkbook.Sheets("Sheet2")
  startRw = 4
  endRw = sh1.Range("AS" & startRw).End(xlDown).Row
  fpath = sh2.Range("I2").Value ' folder u koji se snima
  fname = sh2.Range("I3").Value 'file u koji se snima
  sh2.Activate                 ' Activira se sh2 da ne mora da se menja Snimi XML
  For rw = startRw To endRw    'Petlja kroz popunjene ključeve
    ActiveSheet.Range("F2").Value = sh1.Range("AS" & rw).Value
    SnimiXML fpath, fname
  Next rw
End Sub