excel vba - 高效循环二维数组

Question

我毫无希望地试图找到填充范围内容的更好方法。这种方式会产生正确的结果，但速度很慢。任何人都可以按照如何填充二维阵列或以其他方式加快算法的方向来指出我的正确方向？我会喜欢有人成功的代码片段，甚至只是显示更清晰的方法的链接。

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 

Answer 1

要做到这一点，你有效地生成应该与要写入数据的二维数据，然后它写在一气呵成。

像下面这样。我喜欢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 

Answer 2

当您从XML获得结果时，是否查看了使用XML地图显示信息 - 可能不适合您的情况，但值得一试。

下面的link显示了一些关于在Excel中使用XML地图的东西。

行的语法为XML字符串加载到一个定义地图与此类似：

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

Answer 3

你可能想看看我的代码中的“使用Excel中VBA变长数组用于大规模数据操作“，http://www.experts-exchange.com/A_2684.html

请注意，因为我没有上面的数据与文章一起工作提供了一个示例解决方案（在这种情况下有效地删除前导零），以满足您填写一个范围从2d阵列要求。

注意要点

1. 的代码通过使用区域的处理非contigious范围
2. 当使用变体阵列alwasy测试范围设定数组大小是大于1个细胞 - 如果不是你不能使用变体
3. 从一系列代码readas，运行操作，那么转储回相同的范围
4. 使用值2是略高于值

MOE高效

下面是代码：

'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