Question

我有一些工作要完成，我有9个数据标签（其中一些包含数千行数据）。每个选项卡包含（其中包括）保单号，信用卡和/或借记号。

每个政策号码都会在包含相同信用卡或借记卡的标签中的某个位置匹配，例如

标签1的政策号为123，信用证为100英镑，
标签5还将包含123号保单，借记卡为100英镑。

我要做的是，查看每个标签上的每个政策编号，找到相反金额的位置，为每个政策编号添加位置地址。

我当然不是在寻找任何人为我创建编码，但我正在寻找的是建议。我看过使用循环，但觉得这可能需要很长时间才能处理。我也看过字典，但对这些字体来说比较新，所以我不太自信。

我正在寻找甚至可能吗？如果是这样，任何想法从哪里开始或指针？任何意见是极大的赞赏。谢谢！

Answer 1

你可以

a）创建一个循环遍历所有工作表的 XML文件，

b）通过加载方法和

打开它

c）执行简单的XPath搜索（稍后我会给出一些例子）

我修改了最近的答案（参见excel-vba-xml-parsing-performance）做步骤＆＃34; a）＆＃34;因此使用后期绑定 a）避免引用最新的MS XML Version Version 6（msxml6.dll）和 b）通过所有xheets获取数据。 XML允许您通过XPath在与HTML相当的逻辑结构中的节点上进行结构化搜索。此示例中的根节点称为数据，以下节点使用工作表命名。名称和后续节点获取每个工作表的A：A行中的名称。

XML文件是一个简单的文本文件，您可以通过文本编辑器打开它。最重要的是，您可以使用VBA XMLDOM方法来分析或搜索项目（节点）。我会举例说明你的问题，但给我一些时间。 =＆GT;请参阅答案＆＃34;用法示例＆＃34;，其中我也解释了XML的一些优点（@Peh）。

请注意添加的注释。

Option Explicit

Sub xmlExportSheets()
' Zweck: XML Export over all sheets in workbook
' cf. Site:  [excel-vba-xml-parsing-performance][1][https://stackoverflow.com/questions/40986395/excel-vba-xml-parsing-performance/40987237#40987237][1]
' Note:  pretty printed raw output with line breaks and indentation using an embedded XSLT stylesheet
On Error GoTo ErrHandle
' A. Declarations
' 1  DECLARE XML DOC OBJECT '
' a) Early Binding: VBA REFERENCE MSXML, v6.0 necessary'
'    Dim doc      As New MSXML2.DOMDocument60, xslDoc As New MSXML2.DOMDocument60, newDoc As New MSXML2.DOMDocument60
'    Dim root     As IXMLDOMElement, dataNode As IXMLDOMElement, datesNode As IXMLDOMElement, namesNode As IXMLDOMElement
' b) Late Binding XML Files:
  Dim doc       As Object
  Dim xslDoc    As Object
  Dim newDoc    As Object
' c) Late Binding XML Nodes:
  Dim root      As Object
  Dim sh        As Object   ' xml node containing Sheet Name
  Dim dataNode  As Object
  Dim datesNode As Object
  Dim namesnode As Object

' 2   DECLARE   other variables
  Dim i         As Long
  Dim j         As Long
  Dim tmpValue  As Variant
  Dim tit       As String
  Dim ws        As Worksheet

' B.  XML Docs to Memory
  Set doc = CreateObject("MSXML2.Domdocument.6.0")
  Set xslDoc = CreateObject("MSXML2.Domdocument.6.0")
  Set newDoc = CreateObject("MSXML2.Domdocument.6.0")

' C.  Set DocumentElement (= root node)'
  Set root = doc.createElement("data")
' D.  Create Root Node
  doc.appendChild root


' ===========================
' ITERATE THROUGH Sheets
' ===========================
For Each ws In ThisWorkbook.Sheets
    Set sh = doc.createElement(ws.Name)     '
    root.appendChild sh

  ' ===========================
  ' ITERATE THROUGH ROWS                              ' A2:NNn
  ' ===========================
  For i = 2 To ws.UsedRange.Rows.Count                ' Sheets(1)

    ' DATA ROW NODE '
    Set dataNode = doc.createElement("row")     '
    sh.appendChild dataNode

    ' TABLES NODE (orig.: DATES NODE) '
    Set datesNode = doc.createElement(ws.Cells(1, 1))     ' Dates
    datesNode.Text = ws.Range("A" & i)
    dataNode.appendChild datesNode

    ' NAMES NODE '
    For j = 1 To ws.UsedRange.Columns.Count - 1 ' = 12
        tit = ws.Cells(1, j + 1)
        tmpValue = ws.Cells(i, j + 1)
            Set namesnode = doc.createElement(tit)
            namesnode.Text = tmpValue
            dataNode.appendChild namesnode
    Next j

  Next i

Next ws

' =============================
' PRETTY PRINT RAW OUTPUT (XSL)
' =============================
  xslDoc.LoadXML "<?xml version=" & Chr(34) & "1.0" & Chr(34) & "?>" _
        & "<xsl:stylesheet version=" & Chr(34) & "1.0" & Chr(34) _
        & "                xmlns:xsl=" & Chr(34) & "http://www.w3.org/1999/XSL/Transform" & Chr(34) & ">" _
        & "<xsl:strip-space elements=" & Chr(34) & "*" & Chr(34) & " />" _
        & "<xsl:output method=" & Chr(34) & "xml" & Chr(34) & " indent=" & Chr(34) & "yes" & Chr(34) & "" _
        & "            encoding=" & Chr(34) & "UTF-8" & Chr(34) & "/>" _
        & " <xsl:template match=" & Chr(34) & "node() | @*" & Chr(34) & ">" _
        & "  <xsl:copy>" _
        & "   <xsl:apply-templates select=" & Chr(34) & "node() | @*" & Chr(34) & " />" _
        & "  </xsl:copy>" _
        & " </xsl:template>" _
        & "</xsl:stylesheet>"
' XSLT (Transformation)
  xslDoc.async = False
  doc.transformNodeToObject xslDoc, newDoc
' =================
' Save the XML File
' =================
  newDoc.Save ThisWorkbook.Path & "\Output.xml"

  MsgBox "Successfully exported Excel data to " & ThisWorkbook.Path & "\Output.XML!", vbInformation
' Regular End of procedure
  Exit Sub

 ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical
  Exit Sub

End Sub

注意

工作表名称必须没有空格

添加了注释（重要提示）： XML节点在每个工作表的第一行使用标题。由于修改后的过程通过UsedRange获取标题名称，所以重要的是不要在A行中有任何空单元格：本例中为A.

补充说明 我不知道我的快速回答（标记为＆＃34; a＆＃34;）被某人降级的原因。我认为这有助于争辩： - ）

Answer 2

使用示例

@ Matt555，您可以使用以下代码测试创建的 XML文件，以获取策略的工作表名称＆＃34; 123＆＃34;假设您的标题在A行中：A包含＆＃34;策略＆＃34;并且我已经测试了代码。和＆＃34;借记＆＃34;

@Peh，你是对的，xml dom方法在vba中经常使用。在此连接中使用XML的优势在于通过XPath进行搜索以及在大文件上执行时的灵活性。在过滤唯一值时，我甚至更喜欢数组或字典。可以在节点列表中返回找到的项目编号而不循环遍历整个数据集......

Option Explicit
Sub testPolicy()
   Dim policy
   Dim debit As Double

   policy = "123"
   debit = "100"

   MsgBox "Policy " & policy & " found in " & vbNewLine & _
          findSheetName(policy, debit), vbInformation, "Policy " & policy & " in Tabs"
   ' You can easily split this to an array and analyze the results
End Sub


Function findSheetName(ByVal policy, Optional ByVal debit) As String
' Purpose: Finds Sheet Names where policy AND/OR debit is found
' Note:    Assuming your titles in row A:A contain "policy" and "debit"
'          You can declare xDoc also after Option Explicit to make it public
Dim xDoc    As Object
Dim xNd     As Object ' MSXML.IXMDOMNode
Dim xNdList As Object ' MSXML.IXMLDOMNodeList
Dim s     As String
' XPath expression
Dim xPth  As String

If IsMissing(debit) Then
    xPth = "//row[policy=""" & policy & """]"
Else
    xPth = "//row[policy=""" & policy & """][debit=""" & debit & """]"
End If

' XML to memory
Set xDoc = CreateObject("MSXML2.Domdocument.6.0")
' allow XPath
xDoc.setProperty "SelectionLanguage", "XPath"
xDoc.validateOnParse = False
' ========
' LOAD XML
' ========
xDoc.Load ThisWorkbook.Path & "\" & "output.xml"

' Loop thru NodeList
Set xNdList = xDoc.DocumentElement.SelectNodes(xPth)
Debug.Print xPth, xNdList.Length
For Each xNd In xNdList
    s = s & xNd.ParentNode.NodeName & "|"
Next xNd

Set xDoc = Nothing

findSheetName = s
End Function

需要词典/循环协助

2 个答案: