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:
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.
This link below shows some stuff about using XML maps in Excel.
The syntax of the line to load an XML string into a define map is similar to this:
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)
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
The code handles non contigious ranges by use of Areas
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
The code readas from a range, runs a manipulation, then dumps back to the same range
Using Value2 is slightly moe efficient than 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
Related
Looked high and low, and I haven't found anyone who has talked about this:
I have 2 or more ranges that have been "Unioned" in VBA (so rngUnion.Areas.Count >= 2) and the area ranges are partially contiguous (e.g. rngUnion.Areas(1).address = "A1:Y75", rngUnion.Areas(2).address = "A76:U123", etc.).
What is the simple/efficient way to get the outer bounding range object of the combine areas within rngUnion? I have code below that does this but it seems super kludgy and dumb - I am sure that there is a better way.
Note: I am assuming that there could be other used cells around these areas that are not with the union so I am extremely hesitant to use .CurrentRegion, .UsedRange, or .End(xlUp).Row type methods that are all being suggested for working with ranges.
Sub SomeObfuscatedMethodForGettingAUnionOfPartiallyContiguousAreas()
Dim rng1 As Range: Set rng1 = Range("A1:Y75")
Dim rng2 As Range: Set rng2 = Range("A76:U123")
Dim rngUnion As Range, rngComplete As Range
Set rngUnion = Union(rng1, rng2)
Set rngComplete = GetOuterBoundingRange(rngUnion)
Debug.Print rngComplete.Address 'prints "A1:Y123"
End Sub
Function GetOuterBoundingRange(rngUnion As Range) As Range
Dim minRow As Long: minRow = 2147483647
Dim minCol As Long: minCol = 2147483647
Dim maxRow As Long: maxRow = 0
Dim maxCol As Long: maxRow = 0
Dim minRowTemp As Long
Dim minColTemp As Long
Dim maxRowTemp As Long
Dim maxColTemp As Long
Dim area As Range
For Each area In rngUnion.Areas
minRowTemp = area.Row
maxRowTemp = minRowTemp + area.Rows.Count - 1
minColTemp = area.Column
maxColTemp = minColTemp + area.Columns.Count - 1
If minRowTemp < minRow Then minRow = minRowTemp
If minColTemp < minCol Then minCol = minColTemp
If maxRowTemp > maxRow Then maxRow = maxRowTemp
If maxColTemp > maxCol Then maxCol = maxColTemp
Next area
With rngUnion.parent
Set GetOuterBoundingRange = .Range(.Cells(minRow, minCol), .Cells(maxRow, maxCol))
End With
End Function
As far as I know, there is no build-in function to do so. I don't think your function is that clumsy, in all cases you will need to loop over all areas and find the min and max row and column.
My attempt is a little bit shorter by collecting the numbers into arrays and uses the Min and Max-function, but basically it's doing the same.
Function getR(r As Range) As Range
ReDim minRow(1 To r.Areas.Count) As Long
ReDim maxRow(1 To r.Areas.Count) As Long
ReDim minCol(1 To r.Areas.Count) As Long
ReDim maxCol(1 To r.Areas.Count) As Long
Dim i As Long
For i = 1 To r.Areas.Count
minRow(i) = r.Areas(i).Row
maxRow(i) = r.Areas(i).Row + r.Areas(i).Rows.Count
minCol(i) = r.Areas(i).Column
maxCol(i) = r.Areas(i).Column + r.Areas(i).Columns.Count
Next
With r.Parent
Set getR = .Range(.Cells(WorksheetFunction.Min(minRow), WorksheetFunction.Min(minCol)), _
.Cells(WorksheetFunction.Max(maxRow) - 1, WorksheetFunction.Max(maxCol) - 1))
End With
End Function
This function uses the Application.Range property (Excel) to create the Range Around the Union Range.
Function UnionRange_ƒRangeAround_Set(rUnion As Range) As Range
Dim rOutput As Range, b As Byte
With rUnion
Set rOutput = .Areas(1)
For b = 2 To .Areas.Count
Set rOutput = Range(rOutput, .Areas(b))
Next
End With
Set UnionRange_ƒRangeAround_Set = rOutput
End Function
Since I brought it up, here is a solution which uses a regular expressions. Note for it to work you would need to set a reference to "Microsoft VBScript Regular Expressions 5.5". I pulled all the numbers out of the R1C1 address and used the fact that row numbers and column numbers would alternate, so it would fail if the range in question involved row only or column only references (eg, R3:R4 would break it).
Function getOuterBoundingRange(rngUnion As Range) As Range
Dim regEx As New RegExp
Dim m As Match, oMat As MatchCollection
Dim rowsArr() As Variant
Dim colsArr() As Variant
With regEx
.Global = True
.Pattern = "\d+"
End With
Set oMat = regEx.Execute(rngUnion.Address(, , xlR1C1))
ReDim rowsArr(0 To oMat.Count / 2 - 1)
ReDim colsArr(0 To oMat.Count / 2 - 1)
i = 0
For Each m In oMat
If (i / 2) = Int(i / 2) Then
rowsArr(i / 2) = CLng(m.Value)
Else
colsArr(Int(i / 2)) = CLng(m.Value)
End If
i = i + 1
Next m
With rngUnion.Parent
Set getOuterBoundingRange = .Range(.Cells(WorksheetFunction.Min(rowsArr), WorksheetFunction.Min(colsArr)), _
.Cells(WorksheetFunction.Max(rowsArr), WorksheetFunction.Max(colsArr)))
End With
End Function
Alternative via tricky FilterXML() - //Late Edit as of 2021-11-14
Instead of looping through all areas cell by cell or applying regEx,
I demonstrate how to resolve OP's question alternatively via FilterXML().
I extended #Professor Pantsless'es clever idea to use a R1C1 address of a range Union,
but parsed the address into two parts: the first with entire row indices, and the second with entire column indices.
This allows a minimum/maximum filtering without loops, executed by XPath expressions via FilterXML() (~> see help function getBoundaries).
Function getR(r As Range) As Range
'a) get Boundaries
Dim rc() As Long: rc = getBoundaries(r)
'b) get entire range
With r.Parent
Set getR = .Range(.Cells(rc(1), rc(2)), _
.Cells(rc(3), rc(4)))
End With
End Function
Help function getBoundaries()
Includes the main logic using FilterXML() in three steps:
a) define XPath expressions to find minimal/maximal row/column indices.
b) build a wellformed xml content string by tokenizing the Union range address (where R1C1 mode allows to get numeric values) - uses a further help function getContent().
c) apply FilterXML() based on a wellformed xml content and XPath expressions returning results as a 4-elements array with outer range boundaries.
Function getBoundaries(r As Range) As Long()
'Purp.: return boundaries of range union
'Site: https://stackoverflow.com/questions/69572123/get-outer-bounding-range-of-union-with-multiple-areas
'Date: 2021-10-15
'Auth: [T.M](https://stackoverflow.com/users/6460297/t-m)
'a) define XPath patterns
Const min As String = "//i[not(../i < .)][1]"
Const max As String = "//i[not(../i > .)][1]"
'b)get wellformed xml content (rows|columns)
Dim content As String
'c1)get Row boundaries
content = getContent(r, True) ' help function getContent()
Dim tmp(1 To 4) As Long
tmp(1) = Application.FilterXML(content, min)
tmp(3) = Application.FilterXML(content, max)
'c2)get Column boundaries
content = getContent(r, False) ' << corrected misspelling 2021-11-14 to getContent (inst/of wellformed()
tmp(2) = Application.FilterXML(content, min)
tmp(4) = Application.FilterXML(content, max)
'd) return boundaries array
getBoundaries = tmp
End Function
Help function getContent() (called by above function in section b))
Function getContent(r As Range, ExtractRows As Boolean) As String
'Purp.: get wellformed XML content string
'Meth.: tokenize R1C1-range address into html-like tags
Dim tmp As String
If ExtractRows Then ' extract row numbers
tmp = r.EntireRow.Address(ReferenceStyle:=xlR1C1)
getContent= "<rc><i>" & Replace(Replace(Replace(tmp, "R", ""), ",", ":"), ":", "</i><i>") & "</i></rc>"
Else ' extract column numbers
tmp = r.EntireColumn.Address(ReferenceStyle:=xlR1C1)
getContent= "<rc><i>" & Replace(Replace(Replace(tmp, "C", ""), ",", ":"), ":", "</i><i>") & "</i></rc>"
End If
End Function
Further links
I recommend reading #JvdV 's excellent & nearly encyclopaedic post Extract substrings from string using FilterXML().
Before I start, I just want to thank every contributor ahead of time. I've only posted one question before, and I was amazed at how quickly I got responses and how much I learned after studying the solution. I'm hoping I will have enough reputation points soon to start upvoting good solutions I find here.
Anyways, what I'm trying to do is return one number, and that number is the maximum number of names that appear in a single cell of a worksheet column. Each cell in that column can have any number of names in it. Each name is delimited by a pipe "|", so I count the pipes and then add one to get the number of names in each cell. For example: Cell value is "Bob | Jon | Larry" = 2pipes +1 = 3 names.
My code below works, but I need to do this on tens of thousands of records. I don't think my solution is a good or efficient way to do it (tell me if I'm wrong). So my questions are:
Is there a better way to accomplish this, such as without looping through every cell in the range?
If there isn't a totally different approach to this, how can I avoid actually printing the name counts in cells in a new column? Could I store these values in an array and calculate the max of the array? (maybe there is already a thread on this topic you could point me to?)
Sub charCnt()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = Worksheets("Leasing")
Dim vRange As Variant
Dim iCharCnt As Integer
Dim iRows As Integer
Dim i As Integer
Dim iMax As Integer
Const sFindChar As String = "|"
iRows = ws.Cells(Rows.Count, "A").End(xlUp).Row 'count number of rows
For i = 1 To iRows
vRange = Cells(i, "O") 'column O has the names
iCharCnt = Len(vRange) - Len(Replace(vRange, sFindChar, "")) 'find number of | in single cell.
ws.Cells(i, "W") = iCharCnt 'column W is an empty column I use to store the name counts
Next i
iMax = Application.WorksheetFunction.Max(Range("W:W")) + 1 'return max from column W
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Max number of names in one cell is " & iMax) ' show result
End Sub
Max Number of Substrings
Option Explicit
Sub charCount()
Const cCol As String = "O"
Const fRow As Long = 1
Const Delimiter As String = "|"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Leasing")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, cCol).End(xlUp).Row
Dim rg As Range: Set rg = ws.Cells(fRow, cCol).Resize(lRow - fRow + 1)
Dim Data As Variant: Data = rg.Value
Dim i As Long
For i = 1 To UBound(Data, 1)
Data(i, 1) = Len(Data(i, 1)) - Len(Replace(Data(i, 1), Delimiter, ""))
Next i
Dim iMax As Long: iMax = Application.Max(Data) + 1
MsgBox ("Max number of names in one cell is " & iMax) ' show result
End Sub
A close-to-formula approach
Combining worksheet functions CountA() and FilterXML() allows to get all substring counts separated by the pipe character |:
Sub CountSubstrings(StartCell As Range, TargetRng As Range)
'Purp.: count items separated by pipes
'Meth.: via worksheetfunction FILTERXML()
'Note: assumes target in same sheet as StartCell (could be changed easily)
'a) enter formula into entire target range
Const PATTERN$ = _
"=IF(LEN($),COUNTA(FILTERXML(""<t><s>""&SUBSTITUTE($,""|"",""</s><s>"")&""</s></t>"",""//s"")),0)"
TargetRng.Formula2 = Replace(PATTERN, _
"$", StartCell.Parent.Name & "!" & StartCell.Address(False, False))
'b) optional overwriting of formulae
'TargetRng = TargetRng.Value
'c) display maximum result
MsgBox Application.Max(TargetRng)
End Sub
Hint: You can even shorten code as follows if you want to include the fully qualified workbook + worksheet reference in the formula assignment. Just use the additional argument External:=True in .Address (resulting e.g. in something like '[Test.xlsm]Sheet1'!A2):
TargetRng.Formula2 = Replace(PATTERN, _
"$", StartCell.Address(False, False, External:=True))
Possible Example call
With Sheet1
CountSubstrings .Range("A2"), .Range("D2:D5")
End With
Further link
C.f. JvdV's encyclopaedia-like site demonstrating the various possibilities to use FilterXML()
Brilliant answer by VBasic2008. I thought I would look at it purely as a coding exercise for myself. Alternative below provided for interest only.
Option Explicit
Sub CountMaxNames()
Dim arr1(), i, j, count As Long, tally As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("leasing")
arr1 = ws.Range("O1:O" & ws.Range("O" & Rows.count).End(xlUp).Row)
count = 0: tally = 0
For Each i In arr1
For j = 1 To Len(i)
If Mid(i, j, 1) = "|" Then count = count + 1
Next j
count = count + 1
If count >= tally Then tally = count
count = 0
Next i
MsgBox "Maximum number of names in one cell is " & tally
End Sub
I want to count how many times appear the parameters CA, CU and CH, in an excel that looks like this:
I have tried to use the following code, but as the cells don't contain only the parameter I am searching for, it doesn't work:
Sub ContarOV()
Dim cont As Variant
Dim sumaCA As Variant
Dim sumaCU As Variant
Dim sumaCH As Variant
sumaCA = 0
sumaCU = 0
sumaCH = 0
For cont = 3 To 12
If Cells(cont, 2) = ("CA") Then
sumaCA = sumaCA + 1
End If
If Cells(cont, 2) = ("CU") Then
sumaCU = sumaCU + 1
End If
If Cells(cont, 2) = ("CH") Then
sumaCH = sumaCH + 1
End If
Next cont
End Sub
As per #BigBen, I would try to avoid any iteration. What about one of the following options (assuming your data sits from A2:A?):
Sub Test()
Dim lr As Long, x As Long
Dim arr As Variant
Dim rng As Range
With Sheet1 'Change according to your sheets CodeName
'Get last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get data into memory for method 1
arr = Application.Transpose(.Range("A2:A" & lr).Value)
'Create range object for method 2
Set rng = .Range("A2:A" & lr)
'Method 1: Count values with FILTER
Debug.Print UBound(Filter(arr, "CA")) + 1
Debug.Print UBound(Filter(arr, "CU")) + 1
Debug.Print UBound(Filter(arr, "CH")) + 1
'Method 2: Count values with COUNTIF
Debug.Print WorksheetFunction.CountIf(rng, "CA*")
Debug.Print WorksheetFunction.CountIf(rng, "CU*")
Debug.Print WorksheetFunction.CountIf(rng, "CH*")
End With
End Sub
Btw, I would give sumaCA and your other variables a meaningfull data type, Long in this case.
You can use InStr() to return the position of the desired characters in the string. This would look something like If Not InStr(1, Cells(cont,2).Text, "CH") = 0 Then, but looping through strings is generally a slow process. Unless you have a specific need for looping, I like BigBen's answer a lot better than I like looping with InStr().
First time poster so please excuse any faux pas.
I am trying to write a macro in Excel that iterates through about 1000 rows of a sheet ("PLANNING BOARD") and compares the value in column F to a value in column A of another worksheet ("Copy") that contains 500 rows and 20+ columns (values to be compared are integers). If there is a match, I want the entire row to be deleted from the second worksheet and the rows below to be shifted up. I got a linear search to work, but it is very slow, so I am trying implement a binary search.
Here is the binary search function I have:
Function BinarySearch(lookupArray As Variant, lookupValue As Variant) As Integer
Dim intLower As Integer
Dim intMiddle As Integer
Dim intUpper As Integer
intLower = LBound(lookupArray) 'type mismatch error here
intUpper = UBound(lookupArray)
Do While intLower < intUpper
intMiddle = (intLower + intUpper) \ 2
If lookupValue > lookupArray(intMiddle) Then
intLower = intMiddle + 1
Else
intUpper = intMiddle
End If
Loop
If lookupArray(intLower) = lookupValue Then
BinarySearch = intLower
Else
BinarySearch = -1 'search does not find a match
End If
End Function
And the calling subroutine:
Sub Compare()
Dim h As Integer
For h = 1 To 1000 'iterate through rows of PLANNING BOARD
If Sheets("PLANNING BOARD").Cells(h, 6) <> "" Then 'I want to ignore blank cells
Dim i As Integer
i = BinarySearch(Sheets("Copy").Range("A:A"), Sheets("PLANNING BOARD").Cells(h, 6))
If i <> -1 Then
'delete row and shift up
Sheets("Copy").Rows(i).EntireRow.Delete Shift:=xlUp
End If
End If
Next h
End Sub
I think there is a problem with the lookupArray that I am passing to the BinarySearch function in the Compare subroutine because I keep getting a type mismatch error when passing the lookupArray to VBA's LBound and UBound functions. Any insight will be greatly appreciated. Thanks.
I assume your Copy sheet is sorted on column A.
You need to use Long rather than Integer for all your Dim statements.
Also your routine is being extremely inefficient by reading an entire column and then passing it to your binary search routine. Try only passing a the range that actually has any data in it. (You can use either End(Xlup) from below the data or work with the UsedRange).
Lookup Array is 2-dimensional not 1
You need to make sure you have converted the range to a variant array
You can debug this by using the Locals window to determine the type of LookupArray.
Here is an improved version of your code:
Option Explicit
Function BinarySearch(lookupArray As Variant, lookupValue As Variant) As Long
Dim intLower As Long
Dim intMiddle As Long
Dim intUpper As Long
intLower = LBound(lookupArray)
intUpper = UBound(lookupArray)
Do While intLower < intUpper
intMiddle = (intLower + intUpper) \ 2
' lookupArray is 2-dimensional
If lookupValue > lookupArray(intMiddle, 1) Then
intLower = intMiddle + 1
Else
intUpper = intMiddle
End If
Loop
If lookupArray(intLower, 1) = lookupValue Then
BinarySearch = intLower
Else
BinarySearch = -1 'search does not find a match
End If
End Function
Sub Compare()
Dim h As Long
Dim rngSearched As Range
Dim lCalcmode As Long
Dim i As Long
Application.ScreenUpdating = False
lCalcmode = Application.Calculation
Application.Calculation = xlCalculationManual
For h = 1000 To 1 Step -1 'iterate backwards through rows of PLANNING BOARD
If Sheets("PLANNING BOARD").Cells(h, 6).Value2 <> "" Then 'I want to ignore blank cells
' minimise area being searched
Set rngSearched = Sheets("Copy").Range("A1:A" & Sheets("Copy").Range("A1048576").End(xlUp).Row)
i = BinarySearch(rngSearched.Value2, Sheets("PLANNING BOARD").Cells(h, 6).Value2)
If i <> -1 Then
' delete row and shift up
Sheets("Copy").Rows(i).EntireRow.Delete Shift:=xlUp
End If
End If
Next h
Application.ScreenUpdating = True
Application.Calculation = lCalcmode
End Sub
When the range being passed to the function BinarySearch(), it is not of type Variant; You can however convert it simply by assigning to one. Please try the following:
Under your function BinarySearch,
Dim intLower As Integer
Dim intMiddle As Integer
Dim intUpper As Integer
dim temparry as Variant
temparry = lookupArray
intLower = LBound(temparry)
Same for all other use for lookupArray.
I am trying to speed up a currently working automated workbook.
PHP sends a string similar to the below to VBA:
1[|:#:|]text-one[|:#:|]code-one[|:#:|]qty-one[{:#:}]
2[|:#:|]text-two[|:#:|]code-two[|:#:|]qty-two[{:#:}]
where
[|:#|] represents "new column"
[{:#:}] represents "new row"
When it is parsed by the VBA this is the output:
I currently use the following VBA code to parse this into a workbook:
myArray = Split(myReply, "[{:#:}]")
myRow = 1
For Each element In myArray
myRow = myRow + 1
subArray = Split(element, "[|:#:|]")
myCol = 2
For Each subelement In subArray
myCol = myCol + 1
Cells(myRow, myCol).Value = subelement
Next subelement
Next element
I am about to start optimising the code in this workbook and I am aware I can do something like (pseudo code):
for each element....
Range("C2:F2").Value = Split(element, "[|:#:|]") 'Example row number would be incremental
However is there a way to do it so that I can split into the entire Range?
For example, If I know there are 29 "rows" within the data that has been returned, I would like to be able to use split to place the data into all the rows.
I imagine the syntax would be something similar to the below, however this doesn't seem to work:
Range("C2:F29").Value = Split(Split(element, "[|:#:|]"),"[{:#:}]")
The optimal thing to do is to do everything in native VBA code and not interact with the Excel sheet until the end. Writing to sheet is a time consuming operation, so this procedure does it once and once only, writing the whole two-dimensional array at once, rather than writing it line by line. Therefore no need to disable screen updating, calculation, or anything else.
Function phpStringTo2DArray(ByVal phpString As String) As Variant
Dim iRow As Long
Dim iCol As Long
Dim nCol As Long
Dim nRow As Long
Dim nColMax As Long
Dim lines() As String
Dim splitLines() As Variant
Dim elements() As String
lines = Split(phpString, "[{:#:}]")
nRow = UBound(lines) - LBound(lines) + 1
ReDim splitLines(1 To nRow)
For iRow = 1 To nRow
splitLines(iRow) = Split(lines(iRow - 1), "[|:#:|]")
nCol = UBound(splitLines(iRow)) - LBound(splitLines(iRow)) + 1
' in case rows have different number of columns:
If nCol > nColMax Then nColMax = nCol
Next iRow
Erase lines
'We now have a (Variant) array of arrays. Convert this to a regular 2D array.
ReDim elements(1 To nRow, 1 To nColMax)
For iRow = 1 To nRow
nCol = UBound(splitLines(iRow)) - LBound(splitLines(iRow)) + 1
For iCol = 1 To nCol
elements(iRow, iCol) = splitLines(iRow)(iCol - 1)
Next iCol
Next iRow
Erase splitLines
phpStringTo2DArray = elements
End Function
Example usage:
Dim s As String
Dim v As Variant
s = "1[|:#:|]text-one[|:#:|]code-one[|:#:|]qty-one[{:#:}]2[|:#:|]text-two[|:#:|]code-two[|:#:|]qty-two[{:#:}]"
v = phpStringTo2DArray(s)
'Write to sheet
Range("A1").Resize(UBound(v, 1), UBound(v, 2)) = v
If you want to ignore the final line break [{:#:}], could add this line at the top of the function:
If Right(phpString, 7) = "[{:#:}]" Then phpString = Left(phpString, Len(phpString) - 7)
This wasn't as easy as I originally thought. I can get rid of one loop easily. But there's still an if test, so it doesn't break on empty strings etc. I feel a guru could make this even more efficient.
My worry is that for you this process is taking a lot of time. If you are trying to speed things up, your code doesn't look too horribly inefficient.
More likely if it's running slowly, is that the application.calculation & application.screenUpdating settings are set incorrectly.
Sub takePHP(myString As String)
'This sub takes specially formatted strings from a PHP script,
'and parses into rows and columns
Dim myRows As Variant
Dim myCols As Variant
Dim subRow As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculateManual
myRows = Split(myString, "[{:#:}]")
x = 1
For Each subRow In myRows
bob = Split(subRow, "[|:#:|]")
If UBound(bob) <> -1 Then
Range(Cells(x, 1), Cells(x, UBound(bob) + 1)).Value = bob
x = x + 1
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub