Feste Blöcke aus Excel zu XML

[PeterN]

Hola los Todos!

Ich hoffe Ihr seid alle gesund und munter.

Ich habe eine Excelliste mit festen Blöcken in einer Spalte nach dem Schema:

Code:

<url>
<loc>https://domain.com</loc>
<lastmod>2020-07-07T01:01:01Z</lastmod>
</url>
usw.

Im aktuellen Fall sind es 5700 solche Blöcke aus jeweils 4 Zeilen.

Die würde ich gerne in 150 x 38 Blöcke unterteilen und jeweils eine XML Datei erzeugen nach dem Schema:

Code:

<?xml version="1.0" encoding="UTF-8"?>
<urlset xmlns="http://www.sitemaps.org/schemas/sitemap/0.9">
<url>
<loc>https://domain.com</loc>
<lastmod>2020-07-07T01:01:01Z</lastmod>
</url>
<url>
<loc>https://domain.com</loc>
<lastmod>2020-07-07T01:01:01Z</lastmod>
</url>
usw.
</urlset>

Der erste grosse Block für die erste XML Datei wäre A1:A152 = 4 Werte x 38 Blöcke.
Der zweite dann A153:A304 usw.

Der zu erzeugende Dateiname für die XML Datei(en) sollte dem Schema sitemap001.xml, sitemap002.xml usw. folgen.

Der Speicherort wäre frei definierbar.

Danke und Gruss

Peter

[schauan]

Hallöchen,

das wäre dann so was:

Code:

Sub XML_Out_152()
'(c) schauan
'Variablendeklarationen
Dim strFile$, iCnt%, kCnt%, intF%, boOpen As Boolean
'Startzeilennummer
iCnt = 1
'Schleife ueber alle Zelleintraege bis zur ersten leeren Zelle in SPalte A
Do While Cells(iCnt, 1) <> ""
  'In Zeile 1, 153, 305 usw neues File beginnen
  If iCnt Mod 152 = 1 Then
    'Filezaehler hochsetzen
    kCnt = kCnt + 1
    'Dateiname bilden
    strFile = "C:\Temp\ sitemap" & Format(kCnt, "000") & ".xml"
    'Filenummer ermitteln
    intF = FreeFile
    'Datei zur Ausgabe oeffnen
    Open strFile For Output As #intF
    'Datei offen merken
    boOpen = True
    'Ausgabe des XML-Headers
    Print #intF, "<?xml version=""1.0"" encoding=""UTF-8""?>"
    Print #intF, "<urlset xmlns=""http://www.sitemaps.org/schemas/sitemap/0.9"">"
  End If
  'Zeile ausgeben
  Print #intF, Cells(iCnt, 1).Value
  'in Zeile 152, 304 usw. Datei schliessen
  If iCnt Mod 152 = 0 Then
    'XML-Ende ausgeben
    Print #intF, "</urlset>"
    'Datei schliessen
    Close #intF
    'Datei geschlossen merken
    boOpen = False
  End If
  'Zeilenzaehler hochsetzen
  iCnt = iCnt + 1
'Ende Schleife ueber alle Zelleintraege bis zur ersten leeren Zelle in SPalte A
Loop
'falls doch noch ein File offen ist, dann
If boOpen Then
  'XML-Ende ausgeben
  Print #1, "</urlset>"
  'Datei schliessen
  Close #intF
'Ende falls doch noch ein File offen ist, dann
End If
End Sub

[PeterN]

Hi André!

Funktioniert!

Super!
Klasse!
Danke!

Peter