excel vba - 高效循环二维数组

excel vba - efficiently loop 2d array

提问by toop

I'm hopelessly trying to find a better way of filling a range contents. This way produces the correct results but is very slow. Can anyone point me in the correct direction in terms of how to fill a 2d array or otherwise to speed up the algorithm? I would love a code snippet someone has had success with or even just links that show a cleaner method.

我绝望地试图找到一种更好的方法来填充范围内容。这种方式会产生正确的结果，但速度很慢。任何人都可以在如何填充二维数组或以其他方式加速算法方面为我指出正确的方向吗？我希望有人使用成功的代码片段，甚至只是显示更清晰方法的链接。

here is my OLD code:
----------------
    f = 1
    maxcol = 'func call to get last non blank col ref .ie could return T, R, H.etc

    For f = 1 To UBound(filenames)
        Set aDoc = LoadXmlDoc(filenames(f))
        For Each c In Worksheets("Results").Range("A1:" & maxcol & "1")
                                        c.Offset(f, 0).Value = aNode.Text
                    Next c
        Worksheets("Results").Range(maxcol & "1").Offset(f, 0).Value = filenames(f)
    Next f


UPDATED CODE:
----------

Dim aDoc As DOMDocument
Dim aNode As IXMLDOMNode
Dim numOfXpaths As Integer
Dim filenames As Variant
Dim f As Integer
Dim maxcol As String
Dim rngStart As Range
Dim nColIndex As Long
Dim lngCalc As Long
'Dim numOfFiles As Integer
Dim aXpaths As Variant
        numOfFiles = UBound(filenames)
    colToRow aXpaths, numOfXpaths
    maxcol = Number2Char(numOfXpaths)
        ReDim aValues(1 To numOfFiles, 1 To numOfXpaths + 1) As Variant
        For f = 1 To numOfFiles
            Set aDoc = LoadXmlDoc(filenames(f))
            For nColIndex = 1 To numOfXpaths
                    If aDoc.parseError Then
                        aValues(f, nColIndex) = "XML parse error:" 
                    Else
                      Set aNode = aDoc.selectSingleNode(aXpaths(nColIndex))
                      aValues(f, nColIndex) = aNode.Text
                    End If
            Next nColIndex
            aValues(f, numOfXpaths + 1) = filenames(f)
        Next f
        Worksheets("Results").Range("A1").Offset(1, 0).Resize(numOfFiles, numOfXpaths + 1).Value = aValues


    Function colToRow(ByRef aXpaths As Variant, ByRef numOfXpaths As Integer)
    Dim xpathcount As Integer
    Dim c As Integer
    'Dim aXpaths As Variant
    xpathcount = Worksheets("Xpaths").Cells(Rows.Count, "A").End(xlUp).Row - 1
    ReDim aXpaths(1 To xpathcount + 1) As Variant
    For c = 0 To xpathcount
        Worksheets("Results").Range("A1").Offset(0, c) = Worksheets("Xpaths").Range("A1").Offset(c, 0)
        Worksheets("Results").Range("A1").Offset(0, c).Columns.AutoFit
        aXpaths(c + 1) = Worksheets("Xpaths").Range("A1").Offset(c, 0)
    Next c
    Worksheets("Results").Range("A1").Offset(0, xpathcount + 1) = "Filename"
    'colToRow = xpathcount + 1
    numOfXpaths = xpathcount + 1
    End Function

Function Number2Char(ByVal c) As String
Number2Char = Split(Cells(1, c).Address, "$")(1)
End Function

回答by Joe

To do this efficiently you should generate a 2-dimensional data with the data you want to write, then write it all in one go.

为了有效地做到这一点，您应该用要写入的数据生成一个二维数据，然后一次性写入所有数据。

Something like the following. I prefer 0-based arrays for compatibility with other languages whereas you seem to be using a 1-based array (1 to UBound(filenames). So there may be off-by-one errors in the following untested code:

类似于以下内容。为了与其他语言兼容，我更喜欢基于 0 的数组，而您似乎使用基于 1 的数组 ( 1 to UBound(filenames)。因此，以下未经测试的代码中可能存在一对一错误：

f = 1
maxcol = 'func call to get last non blank col ref .ie could return T, R, H.etc

' 2D array to hold results    
' 0-based indexing: UBound(filenames) rows and maxcol columns
Dim aValues(0 to UBound(filenames)-1, 0 To maxcol-1) As Variant
Dim rngStart As Range
Dim nColIndex As Long

For f = 1 To UBound(filenames)
    Set aDoc = LoadXmlDoc(filenames(f))

    aValues(f-1, 0) = filenames(f)

    For nColIndex = 1 To maxCol-1
        aValues(f-1, nColIndex) = aNode.Text
    Next nColIndex

Next f

' Copy the 2D array in one go
Worksheets("Results").Offset(1,0).Resize(UBound(filenames),maxCol).Value = aValues

回答by Jon Egerton

As you're getting you results from XML, have you looked into using XML Maps to display the information - might not be suitable for your situation, but worth a try.

当您从 XML 获得结果时，您是否考虑过使用 XML Maps 来显示信息 - 可能不适合您的情况，但值得一试。

This linkbelow shows some stuff about using XML maps in Excel.

下面的这个链接显示了一些关于在 Excel 中使用 XML 映射的内容。

The syntax of the line to load an XML string into a define map is similar to this:

将 XML 字符串加载到定义映射中的行的语法类似于：

ActiveWorkbook.XmlMaps("MyMap").ImportXml(MyXMLDoc,True)

回答by brettdj

You might want to look at my code in "Using Variant Arrays in Excel VBA for Large Scale Data Manipulation", http://www.experts-exchange.com/A_2684.html(further detail provided in the hyperlink)

您可能想查看“在 Excel VBA 中使用变量数组进行大规模数据操作”中的代码，http://www.experts-exchange.com/A_2684.html（在超链接中提供了更多详细信息）

Note that as I don't have your data above to work with the article provides a sample solution (in this case efficiently deleting leading zeroes) to meet you filling a range from a 2d array requirement.

请注意，由于我没有上面的数据来处理文章，因此提供了一个示例解决方案（在这种情况下有效地删除前导零）来满足您填充二维数组要求的范围。

Key points to note

注意要点

1. The code handles non contigious ranges by use of Areas
2. When using variant arrays alwasy test that the range setting the array size is bigger than 1 cell - if not you cant use a variant
3. The code readas from a range, runs a manipulation, then dumps back to the same range
4. Using Value2 is slightly moe efficient than Value

1. 该代码通过使用区域处理非连续范围
2. 使用变体数组时，请始终测试设置数组大小的范围是否大于 1 个单元格 - 如果不是，则不能使用变体
3. 代码从一个范围读取，运行一个操作，然后转储回相同的范围
4. 使用 Value2 比 Value 更高效

Here is the code:

这是代码：

'Press Alt + F11 to open the Visual Basic Editor (VBE)
'From the Menu, choose Insert-Module.
'Paste the code into the right-hand code window.
'Press Alt + F11 to close the VBE
'In Xl2003 Goto Tools … Macro … Macros and double-click KillLeadingZeros

Sub KillLeadingZeros()
    Dim rng1 As Range
    Dim rngArea As Range
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngCalc As Long
    Dim objReg As Object
    Dim X()


    On Error Resume Next
    Set rng1 = Application.InputBox("Select range for the replacement of leading zeros", "User select", Selection.Address, , , , , 8)
    If rng1 Is Nothing Then Exit Sub
    On Error GoTo 0

    'See Patrick Matthews excellent article on using Regular Expressions with VBA
    Set objReg = CreateObject("vbscript.regexp")
    objReg.Pattern = "^0+"

    'Speed up the code by turning off screenupdating and setting calculation to manual
    'Disable any code events that may occur when writing to cells
    With Application
        lngCalc = .Calculation
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    'Test each area in the user selected range

    'Non contiguous range areas are common when using SpecialCells to define specific cell types to work on
    For Each rngArea In rng1.Areas
        'The most common outcome is used for the True outcome to optimise code speed
        If rngArea.Cells.Count > 1 Then
           'If there is more than once cell then set the variant array to the dimensions of the range area
           'Using Value2 provides a useful speed improvement over Value. On my testing it was 2% on blank cells, up to 10% on non-blanks    
            X = rngArea.Value2
            For lngRow = 1 To rngArea.Rows.Count
                For lngCol = 1 To rngArea.Columns.Count
                    'replace the leading zeroes
                    X(lngRow, lngCol) = objReg.Replace(X(lngRow, lngCol), vbNullString)
                Next lngCol
            Next lngRow
            'Dump the updated array sans leading zeroes back over the initial range
            rngArea.Value2 = X
        Else
            'caters for a single cell range area. No variant array required
            rngArea.Value = objReg.Replace(rngArea.Value, vbNullString)
        End If
    Next rngArea

    'cleanup the Application settings
    With Application
        .ScreenUpdating = True
        .Calculation = lngCalc
        .EnableEvents = True
    End With

    Set objReg = Nothing
    End Sub