Girintiler yoluyla XLS Hücreleri'nden XML dosyası oluşturma

Question

Yapmaya çalıştığım şey bir XLS dosyasını ayrıştırarak bir XML dosyası oluşturmaktır. Bir örnek daha alakalı olmalıdır:

| tag1  |   |   |   | 
|   | tag2  |   |   | 
|   |   | tag3  | tag3Value | 
|   |   | tag4  | tag4Value | 
|   | tag5  |   |   | 
|   |   | tag6  | tag6Value | 
|   |   |   |   | 

biz bu hücrelerdir hayal, aşağıdaki .xml kodu için eşdeğer olacaktır. her seferinde bir hücreyi yönetmek ve sadece "<" & Hücre (x, y) & ">" yaparak bu kadar zor olmazdı

<tag1> 
    <tag2> 
     <tag3> tag3Value </tag3> 
     <tag4> tag4Value </tag4> 
    </tag2> 
    <tag5> 
     <tag6> tag6Value </tag6> 
    </tag5> 
</tag1> 

Ama zarif bir çözüm istedi.

Sub lol() 
    Sheet1.Activate 

    Dim xmlDoc As MSXML2.DOMDocument 
    Dim xmlNode As MSXML2.IXMLDOMNode 

    Set xmlDoc = New MSXML2.DOMDocument 
    createXML xmlDoc 
End Sub 

Sub createXML(xmlDoc As MSXML2.DOMDocument) 
    Dim newNode As MSXML2.IXMLDOMNode 

    If Not (Cells(1, 1) = "") Then 

     'newNode.nodeName = Cells(1, 1) 
     ReplaceNodeName xmlDoc, newNode, Cells(1, 1) 

     createXMLpart2 xmlDoc, newNode, 2, 2 
     xmlDoc.appendChild newNode 
    End If 
    xmlDoc.Save "E:\saved_cdCatalog.xml" 
End Sub 

Sub createXMLpart2(xmlDoc As MSXML2.DOMDocument, node As MSXML2.IXMLDOMElement, i As Integer, j As Integer) 
    Dim newNode As MSXML2.IXMLDOMElement 
    If Not (Cells(i, j) = "") Then 

     If (Cells(i, j + 1) = "") Then 

      'newNode.nodeName = Cells(i, j) 
      ReplaceNodeName xmlDoc, newNode, Cells(i, j) 

      createXMLpart2 xmlDoc, newNode, i + 1, j + 1 
     Else 
      'newNode.nodeName = "#text" 
      ReplaceNodeName xmlDoc, newNode, "#text" 

      'newNode.nodeValue = Cells(i, j + 1) 
      createXMLpart2 xmlDoc, newNode, i + 1, j 
     End If 
     node.appendChild (newNode) 
    End If 
End Sub 

Private Sub ReplaceNodeName(oDoc As DOMDocument, oElement As IXMLDOMElement, newName As String) 
     Dim ohElement As IXMLDOMElement 
     Dim sElement As IXMLDOMElement 
     Dim oChild As IXMLDOMNode 

     ' search the children ' 
     If Not oElement Is Nothing Then 
       Set ohElement = oElement.parentNode 
       Set sElement = oDoc.createElement(newName) 

       For Each oChild In oElement.childNodes 
         Call sElement.appendChild(oChild) 
       Next 

       Call ohElement.replaceChild(sElement, oElement) 
     End If 
End Sub 

Sorunlar: Ben node.nodeName = "NewName" yaparak bir düğümün adını değiştiremezsiniz fark etmemişti ilk başta bir çözüm bulduk İşte şimdiye kadar benim uygulamasıdır StackOverflow aslında: Change NodeName of an XML tag element using MSXML

Bu yüzden düğümlerimi yeniden adlandırma girişimlerimi yorumladım ve sürümü ReplaceNodeName yöntemiyle denedim.

Asıl sorun: createXMLpart2 öğesinden node.appendChild (newNode) bana bir sorun veriyor: "newNode" değişkeni ayarlanmamış. Şaşkınım.

Answer 1

böyle Belki bir şey ...

Sub Tester() 

Dim r As Range 
Dim xmlDoc As New MSXML2.DOMDocument 
Dim xmlNodeP As MSXML2.IXMLDOMNode 
Dim xmlNodeTmp As MSXML2.IXMLDOMNode 
Dim bDone As Boolean 

    Set r = ActiveSheet.Range("A1") 

    Do While Not r Is Nothing 

     Set xmlNodeTmp = xmlDoc.createElement(r.Value) 
     If Len(r.Offset(0, 1).Value) > 0 Then 
      xmlNodeTmp.appendChild xmlDoc.createTextNode(r.Offset(0, 1).Value) 
     End If 

     If Not xmlNodeP Is Nothing Then 
      xmlNodeP.appendChild xmlNodeTmp 
     Else 
      xmlDoc.appendChild xmlNodeTmp 
     End If 
     Set xmlNodeP = xmlNodeTmp 

     If Len(r.Offset(1, 0).Value) > 0 Then 
      Set r = r.Offset(1, 0) 'sibling node 
      Set xmlNodeP = xmlNodeP.ParentNode 
     ElseIf Len(r.Offset(1, 1).Value) > 0 Then 
      Set r = r.Offset(1, 1) 'child node 
     Else 
      Set r = r.Offset(1, 0) 
      Set xmlNodeP = xmlNodeP.ParentNode 
      Do While Len(r.Value) = 0 
       If r.Column > 1 Then 
        Set r = r.Offset(0, -1) 
        Set xmlNodeP = xmlNodeP.ParentNode 
       Else 
        Set r = Nothing 
        Exit Do 
       End If 
      Loop 
     End If 

    Loop 
    Debug.Print xmlDoc.XML 
End Sub 

Answer 2

VBA'da uzman değilim, ancak kodunuza bakarak, neden newNode'un neden başlatılacağını anlamıyorum.

createXMLpart2()'un başlangıcında, Dim newNode As MSXML2.IXMLDOMElement olarak bildirirsiniz, ancak buna bir değer verir misiniz?

Answer 3

I (örneğin döngüler bir demet) saf VBA kodunu gitmeye karar verdi. Başladığım şey oldukça küçüktü, ama sonra "ihtiyaçlar değişirse?" Diye düşündüm. Başka bir deyişle, örneğin ek olarak, aşağıdakiler de geçerli oldu ne olur: anlamsız yazılar içeren bir demet gibi görünebilir, ama temelde sütunda önce ve ötesinde değerlerle etiketleri koyuyor

tag1        
    |tag2 | | | | | | 
    | |tag3 |tag3value | | | | 
    | |tag4 |tag4value | | | | 
    |tag5 | | | | | | 
    | |tag6 |tag6value | | | | 
tag9 | | | | | | | 
    |tag10 |tag10value | | | | | 
tag11 | | | | | | | 
    |tag12 | | | | | | 
    | |tag13 | | | | | 
    | | |tag14 |tag14value | | | 
    | | |tag15 |tag15value | | | 
tag16 |tag16value | | | | | | 
tag17 | | | | | | | 
    |tag18 | | | | | | 
    | |tag19 | | | | | 
    | | |tag20 | | | | 
    | | | |tag21 | | | 
    | | | | |tag22 | | 
    | | | | | |tag23 |tag23value 
    | | | | | |tag24 |tag24value 
    | | | |tag25 |tag25value | | 

4.

<tag1> 
    <tag2> 
     <tag3>tag3value</tag3> 
     <tag4>tag4value</tag4> 
    </tag2> 
    <tag5> 
     <tag6>tag6value</tag6> 
    </tag5> 
</tag1> 
<tag9> 
    <tag10>tag10value</tag10> 
</tag9> 
<tag11> 
    <tag12> 
     <tag13> 
      <tag14>tag14value</tag14> 
      <tag15>tag15value</tag15> 
     </tag13> 
    </tag12> 
</tag11> 
<tag16>tag16value</tag16> 
<tag17> 
    <tag18> 
     <tag19> 
      <tag20> 
       <tag21> 
        <tag22> 
         <tag23>tag23value</tag23> 
         <tag24>tag24value</tag24> 
        </tag22> 
       </tag21> 
       <tag25>tag25value</tag25> 
      </tag20> 
     </tag19> 
    </tag18> 
</tag17> 

Ve modül yapar bu yüzden:

bu xml giyinmek olsaydı, böyle bir şey olmazdı

'Assumptions: 
'1. No blank columns 
'2. XML values start at A1 
Option Explicit 

Dim m_lCurrentRow As Long 'The current row in the range of cells 
Dim m_xmlSheetRange As Range 'The current range of cells containing values 

'Let the fun begin 
Sub DoTheFun() 
    Dim lastUsedCell As Range 'The cell in the outer most row in th outer most column that contains a value 
    Dim lTotalRows As Long 'Total number of rows 
    Dim iCurrentColumn As Integer 


    'Find the very last used cell on a Worksheet: 
    'http://www.ozgrid.com/VBA/ExcelRanges.htm 
    Set lastUsedCell = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious) 

    'Set the range of values to check from A1 to wherever the last cell is located 
    Set m_xmlSheetRange = Range("$A$1:" & lastUsedCell.Address) 
    'Initialize (Sheets have an Option Base 1) 
    iCurrentColumn = 1 
    m_lCurrentRow = 1 
    lTotalRows = m_xmlSheetRange.Rows.Count 

    'Loop through all rows to create the XML string 
    Do Until m_lCurrentRow > lTotalRows 
     'Make sure adjacent cell does not have a value. 
     If m_xmlSheetRange(m_lCurrentRow, iCurrentColumn + 1) = "" Then 

      'Start the search to find a tag with a value (write the surrounding tags as needed) 
      Debug.Print FindTagWithValue(iCurrentColumn) 

      iCurrentColumn = FindTagColumn(iCurrentColumn) 
     Else 'Adjacent cell has a value so just write out the tag and value 
      Debug.Print BuildTagWithValue(iCurrentColumn) 
     End If 
    Loop 


End Sub 
'Recursive function that calls itself till a tag with a value is found. 
Function FindTagWithValue(iCurrentColumn As Integer) As String 
    Dim sXml As String 
    Dim sMyTag As String 
    Dim iPassedColumn As Integer 
    Dim bTagClosed As Boolean 

    iPassedColumn = iCurrentColumn 

    'Get the opening and surrounding tag 
    sMyTag = m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) 
    sXml = String(iCurrentColumn - 1, vbTab) & "<" & sMyTag & ">" & vbCrLf 

    'Move to the next cell and next row 
    m_lCurrentRow = m_lCurrentRow + 1 
    iCurrentColumn = iCurrentColumn + 1 

    bTagClosed = False 'Intialize 

    Do 
     If m_xmlSheetRange(m_lCurrentRow, iCurrentColumn + 1) = "" Then 
      'Adjancent cell to current position does not have value. Start recursion till we find it. 
      sXml = sXml & FindTagWithValue(iCurrentColumn) 
     Else 
      'A value for a tag has been found. Build the xml for the tag and tag value 
      sXml = sXml & BuildTagWithValue(iCurrentColumn) 

      'See if next row is on same level 
      If m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) <> "" And iPassedColumn < iCurrentColumn Then 
       sXml = sXml & String(iPassedColumn - 1, vbTab) & "</" & sMyTag & ">" & vbCrLf 
       sMyTag = m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) 
       bTagClosed = True 
      End If 
     End If 
    'Keep looping till the current cell is empty or until the current column is less than the passed column 
    Loop Until m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) = "" Or iPassedColumn >= iCurrentColumn 

    If Not bTagClosed Then 
     sXml = sXml & String(iPassedColumn - 1, vbTab) & "</" & sMyTag & ">" & vbCrLf 
    End If 

    FindTagWithValue = sXml 

    Exit Function 

End Function 
'A cell with a value has been found that also contains an adjacent cell with a value. Wrap the tag around the value. 
Function BuildTagWithValue(iCurrentColumn As Integer) 
    Dim sXml As String 
    Dim sMyTag As String 
    Dim sMyTagValue As String 

    Do 

     sMyTag = m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) 
     sMyTagValue = m_xmlSheetRange(m_lCurrentRow, iCurrentColumn + 1) 
     sXml = sXml & String(iCurrentColumn - 1, vbTab) & "<" & sMyTag & ">" & sMyTagValue & "</" & sMyTag & ">" & vbCrLf 
     m_lCurrentRow = m_lCurrentRow + 1 
    'Keep looping till you run out of tags with values in this column 
    Loop Until m_xmlSheetRange(m_lCurrentRow, iCurrentColumn + 1) = "" 

    'Find the next valid column 
    iCurrentColumn = FindTagColumn(iCurrentColumn) 

    BuildTagWithValue = sXml 

    Exit Function 
End Function 
'Find the cell on the current row which contains a value. 
Function FindTagColumn(iCurrentColumn) As Integer 
    Dim bValidTagFound As Boolean 

    bValidTagFound = False 
    Do Until bValidTagFound 
     If m_xmlSheetRange(m_lCurrentRow, iCurrentColumn) = "" Then 
      If iCurrentColumn = 1 Then 
       bValidTagFound = True 
      Else 
       iCurrentColumn = IIf(iCurrentColumn = 1, 1, iCurrentColumn - 1) 
      End If 
     Else 
      bValidTagFound = True 
      If iCurrentColumn = 1 Then 
       'Do nothing 
      Else 
       If m_xmlSheetRange(m_lCurrentRow, iCurrentColumn - 1) <> "" Then 
        iCurrentColumn = iCurrentColumn - 1 
       End If 
      End If 
     End If 
    Loop 

    FindTagColumn = iCurrentColumn 
    Exit Function 
End Function 

Yani, beklenenden biraz daha uzun ve zariften daha dayanıklı olabilir ... ama işe yarıyor.