[英]excel vba - efficiently loop 2d array
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
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
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 link below 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)
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) 您可能想看一下我的代码,该文章在http://www.experts-exchange.com/A_2684.html (在Excel VBA中使用变体数组进行大规模数据操作)(更多详细信息在超链接中提供)
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. 请注意,由于我没有上面的数据可用于本文,因此提供了一个示例解决方案(在这种情况下,是有效删除前导零),可以满足您满足2d数组要求的范围。
Key points to note 注意事项
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.