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