Excel VBA - эффективно цикл 2d массив

Question

Я безнадежно пытаюсь найти лучший способ заполнить содержимое диапазона.Этот способ дает правильные результаты, но очень медленный.Кто-нибудь может указать мне правильное направление с точки зрения того, как заполнить 2d-массив или иным образом ускорить алгоритм?Мне бы понравился фрагмент кода, который кто-то имел успех или даже ссылки, которые показывают более чистый метод.

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 для отображения информации - может не подходить для вашей ситуации, но стоит попробовать.

Эта ссылка ниже показывает некоторые вещи об использовании карт XML в Excel.

Синтаксис строки для загрузки строки XML в определяемую карту аналогичен следующему:

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

Answer 3

Возможно, вы захотите взглянуть на мой код в разделе «Использование массивов вариантов в Excel VBA для крупномасштабных манипуляций с данными», http://www.experts -exchange.com / A_2684.html (более подробная информация приведена в гиперссылке)

Обратите внимание, что поскольку у меня нет ваших данных выше, для работы со статьей предлагается пример решения (в данном случае эффективное удаление начальных нулей), чтобы удовлетворить вас, заполняя диапазон из требования к 2d-массиву.

Ключевые примечания к сведению

1. Код обрабатывает неконкурентные диапазоны с помощью областей
2. При использовании всегда проверяемого массива вариантов, диапазон, устанавливающий размер массива, больше 1ячейка - если нет, вы не можете использовать вариант
3. Код читает из диапазона, выполняет манипуляцию, а затем сбрасывает обратно в тот же диапазон
4. Использование Value2 немного более эффективно, чем Value

Вот код:

'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