This one more version - this will help in generic
Public strSubTag As String
Public iStartCol As Integer
Public iEndCol As Integer
Public strSubTag2 As String
Public iStartCol2 As Integer
Public iEndCol2 As Integer
Sub Create()
Dim strFilePath As String
Dim strFileName As String
'ThisWorkbook.Sheets("Sheet1").Range("C3").Activate
'strTag = ActiveCell.Offset(0, 1).Value
strFilePath = ThisWorkbook.Sheets("Sheet1").Range("B4").Value
strFileName = ThisWorkbook.Sheets("Sheet1").Range("B5").Value
strSubTag = ThisWorkbook.Sheets("Sheet1").Range("F3").Value
iStartCol = ThisWorkbook.Sheets("Sheet1").Range("F4").Value
iEndCol = ThisWorkbook.Sheets("Sheet1").Range("F5").Value
strSubTag2 = ThisWorkbook.Sheets("Sheet1").Range("G3").Value
iStartCol2 = ThisWorkbook.Sheets("Sheet1").Range("G4").Value
iEndCol2 = ThisWorkbook.Sheets("Sheet1").Range("G5").Value
Dim iCaptionRow As Integer
iCaptionRow = ThisWorkbook.Sheets("Sheet1").Range("B3").Value
'strFileName = ThisWorkbook.Sheets("Sheet1").Range("B4").Value
MakeXML iCaptionRow, iCaptionRow + 1, strFilePath, strFileName
End Sub
Sub MakeXML(iCaptionRow As Integer, iDataStartRow As Integer, sOutputFilePath As String, sOutputFileName As String)
Dim Q As String
Dim sOutputFileNamewithPath As String
Q = Chr$(34)
Dim sXML As String
'sXML = sXML & "<rows>"
' ''--determine count of columns
Dim iColCount As Integer
iColCount = 1
While Trim$(Cells(iCaptionRow, iColCount)) > ""
iColCount = iColCount + 1
Wend
Dim iRow As Integer
Dim iCount As Integer
iRow = iDataStartRow
iCount = 1
While Cells(iRow, 1) > ""
'sXML = sXML & "<row id=" & Q & iRow & Q & ">"
sXML = "<?xml version=" & Q & "1.0" & Q & " encoding=" & Q & "UTF-8" & Q & "?>"
For iCOl = 1 To iColCount - 1
If (iStartCol = iCOl) Then
sXML = sXML & "<" & strSubTag & ">"
End If
If (iEndCol = iCOl) Then
sXML = sXML & "</" & strSubTag & ">"
End If
If (iStartCol2 = iCOl) Then
sXML = sXML & "<" & strSubTag2 & ">"
End If
If (iEndCol2 = iCOl) Then
sXML = sXML & "</" & strSubTag2 & ">"
End If
sXML = sXML & "<" & Trim$(Cells(iCaptionRow, iCOl)) & ">"
sXML = sXML & Trim$(Cells(iRow, iCOl))
sXML = sXML & "</" & Trim$(Cells(iCaptionRow, iCOl)) & ">"
Next
'sXML = sXML & "</row>"
Dim nDestFile As Integer, sText As String
''Close any open text files
Close
''Get the number of the next free text file
nDestFile = FreeFile
sOutputFileNamewithPath = sOutputFilePath & sOutputFileName & iCount & ".XML"
''Write the entire file to sText
Open sOutputFileNamewithPath For Output As #nDestFile
Print #nDestFile, sXML
iRow = iRow + 1
sXML = ""
iCount = iCount + 1
Wend
'sXML = sXML & "</rows>"
Close
End Sub