Recently I was wondering about the possibility of speeding up the program by switching a part of the code below:
Dim cell as Variant
Dim myValues() as Double
ReDim myValues(myRange.Count - 1)
Dim i as Integer: i = 0
For Each cell in myRange.Cells
myValue(i) = cell.Value
i = i + 1
Next cell
into a loop where I could refer to the value of each cell directly, instead of instantiating a cell object, assigning it a cell value from a given range, and then extracting the cell value.
In my mind, the pseudocode would look something like this:
Dim cellValue as Double
Dim myValues() as Double
ReDim myValues(myRange.Count - 1)
Dim i as Integer: i = 0
For each cellValue in myRange.Cells.Values
myValues(i) = cellValue
i = i + 1
Next cellValue
If my overall concept is wrong from the start, or if you can't get the cells values from Range faster, then there was no question.
Due to the fact that this is my first post, I could have written something incorrectly / in wrong posting convention. Let me know and I'll fix it.
Cheers
As #SJR notes, this is a common way to access data from a range without going cell-by-cell
Dim arr, i as long, rng As Range
Set rng = Activesheet.Range("A1:B20")
arr = rng.Value 'arr is now a 2D array (1 To 20, 1 To 2)
'Note: base is 1 and not the more-typical 0
For i = 1 to ubound(arr,1)
Debug.Print arr(i, 1), arr(i, 2)
Next i
arr(3, 2) = 999
rng.value = arr 'put the data back to the range
If the reason is for getting rid of the 2D array a function like this can be the solution:
Function VectorFromRange(rng As Range) As Variant
Dim arrIn As Variant
arr = rng.value 'Dumping the data from range
Dim i As Long
Dim item As Variant
ReDim arrOut(1 To rng.Cells.Count) As Variant
For Each item In arr
i = i + 1
arrOut(i) = item
Next item
VectorFromRange = arrOut
End Function
Related
I want to store a range of variable size in an one-dimensional array. The range starts at A2 and goes to the last row of the same column. My approach looks like that. It's flawed.
Option Explicit
Sub Range_to_Array()
Dim i, j, k As Integer
Dim arr1(), arr2(), arr3(), arr4() As Variant
With Worksheets("table1")
arr1() = .Cells(.Range("A2"), .Range("A1").End(xlDown).Row)
End With
End Sub
Please, try the next way. Application.Transpose transforms a 2D array with a column in a 1D type. No iteration needed:
Sub Array1DFromColumnRange()
Dim ws As Worksheet, lastR As Long, arr
Set ws = Worksheets("table1")
lastR = ws.Range("A" & ws.rows.count).End(xlUp).Row
arr = Application.Transpose(ws.Range("A2:A" & lastR).Value)
Debug.Print Join(arr, "|") 'just to visually see the result in Immediate Window (Ctrl + G)...
End Sub
The returned 1D array is 1 based, as the 2D array directly extracted from a range. To transform it in zero based type, can be done without iteration, too:
'change the array type to be zero based:
ReDim Preserve arr(0 To UBound(arr) - 1)
Debug.Print LBound(arr)
Debug.Print Join(arr, "|")
Your problem is that your Range-Definition is wrong.
Cells expect 2 parameters (row and column) to address one cell. This is not what you want, and even if, your parameters would be wrong.
What you need in your case is Range.
Now Range can be called either with one or two parameters.
If you call it with one parameter, this defines the whole range.
Examples: Range("A1") or Range("B2:C5") or Range("B:B")
Whats often used in VBA is something like Range("A1:A" & lastRow)
If you call it with two parameters, those two parameters define the first and last cell of the range.
Examples: Range(Range("A1"), Range("C10")) or Range(Cells(1, 1), Cells(10, 3))
I would advice to define an intermediate variable to save the Range - makes it much easier to debug. Also the row number of the last cell should go into an intermediate variable.
In your case you could use one of the following
Dim r As Range, lastRow As Long
' Get the last row in use (usually its better to go up from the end of the sheet)
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
' 2 parameters
Set r = .Range(.Cells(2, 1), .Cells(2, lastRow))
' 1 Parameter, last row is concatenated to the range definition
Set r = .Range("A2:A" & lastRow)
' Use Resize
Set r = .Range("A2").Resize(lastRow-1, 1) ' -1 because you start at row 2
arr1 = r.Value
Try this instead.
Sub Range_to_Array()
Dim i As Integer, j As Integer, k As Integer
Dim arr1() As Variant, arr2() As Variant, arr3() As Variant, arr4() As Variant
Dim myRange As Range
With Worksheets("table1")
arr1 = .Range(.Range("A2"), .Range("A1").End(xlDown)).Value
End With
Debug.Print arr1(1, 1)
End Sub
Also please note that in order to properly declare variables, you need to specify data type for each variable separately.
Dim i, j, k As Integer
actually means
Dim i As Variant, j As Variant, k As Integer
I thought this would be simple, but apparently the geniuses at Microsoft think differently.
I am writing Excel VBA to loop through the rows in an Excel worksheet and for each row (a Range object), I want to extract the cell values as an array. I've done some searching and found some supposed solutions that are not at all intuitive, nor do they work.
Does anyone have suggestions on how to do this?
Private Sub Separate_By_DC()
Dim row_ As Range
Dim row_str As String
For Each row_ In ActiveSheet.UsedRange.Rows
Dim arr As Variant
arr = Row_To_Array(row_)
Debug.Print UBound(arr) - LBound(arr) + 1
' row_str = Concat_Row(row_)
' Debug.Print row_str
Next row_
End Sub
Private Function Row_To_Array(row_ As Range) As Variant
Row_To_Array = row_.Value
End Function
Think the most easiest way would be:
Sub test()
Dim mArr As Variant
Dim i As Long
mArr = Application.Transpose(Range("A1:A10")) 'Transpoose to make the array one dimensional
'loop through the array
For i = LBound(mArr, 1) To UBound(mArr, 1) 'For one dimensional you can remove ",1"
'do something with mArr value
Cells(i, "C").Value = mArr(i) 'Print the array value
Next i
End Sub
For 2 dimensional array you can loop through it by state the dimensional index:
Dim mArr As Variant
Dim i As Long
mArr = Range("A1:A10") 'Use 2 dimension
'loop through the array
For i = LBound(mArr, 1) To UBound(mArr, 1)
'do something with mArr value
Cells(i, "C").Value = mArr(i, 1)
Next i
I have the following code:
Dim lRow As Long
Dim c As Variant
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
c = Application.Transpose(ws.Range("A2:A" & lRow).Value2)
As long as lRow is > 2 then c becomes a Variant/Variant(1 to x) i.e. an array of Variant/String with values from column A - this is what I need!
However, sometimes the lRow is 2 - this means that c becomes just a string (instead of an array with one entry) - this messes up code further down the sub.
Is there a way I can use Application.Transpose(ws.Range("A2:A" & lRow).Value2) to produce an actual array instead of a Variant? Or somehow force c to always be the array?
Or do I just need to do if checks on the type and build more logic into the whole thing?
I tried Dim c() As String but that's not what Transpose produces...
You should read the range first into a Range variable and then transpose only if it has at least 2 cells:
Dim lRow As Long
Dim c() As Variant
Dim rng As Range
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A2:A" & lRow)
If rng.Count > 1 Then
c = Application.Transpose(rng.Value2)
Else
ReDim c(1 To 1, 1 To 1)
c(1, 1) = rng.Value2
End If
Alternatively, you could use a separate function to get the values from a range into an array:
Private Function RangeToArray(ByVal rng As Range) As Variant()
If rng Is Nothing Then Err.Raise 91, "RangeToArray", "Range not set"
If rng.Areas.Count > 1 Then Err.Raise 5, "RangeToArray", "Multi-area range"
If rng.Count > 1 Then
RangeToArray = rng.Value2
Else
Dim arr(1 To 1, 1 To 1) As Variant
arr(1, 1) = rng.Value2
RangeToArray = arr
End If
End Function
But note that when applying Transpose to a 2-dimensional array of 1 value it actually converts it to a 1-dimensional array:
Dim lRow As Long
Dim c() As Variant
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
c = Application.Transpose(RangeToArray(ws.Range("A2:A" & lRow))) 'c is 1-D if range has only 1 cell
So, the first choice is probably better.
Finally, you could use your own version of Transpose. See my array repository
EDIT 1
Use the following method if you only need 1D Arrays. It works with rows and columns.
Private Function OneDRangeTo1DArray(ByVal rng As Range) As Variant()
Const methodName As String = "OneDRangeTo1DArray"
If rng Is Nothing Then
Err.Raise 91, methodName, "Range not set"
ElseIf rng.Areas.Count > 1 Then
Err.Raise 5, methodName, "Multi-area range"
ElseIf rng.Rows.Count > 1 And rng.Columns.Count > 1 Then
Err.Raise 5, methodName, "Expected 1-row or 1-column range"
End If
Dim arr() As Variant
If rng.Count = 1 Then
ReDim arr(1 To 1)
arr(1) = rng.Value2
Else
Dim v As Variant
Dim i As Long
ReDim arr(1 To rng.Count)
i = 0
For Each v In rng.Value2
i = i + 1
arr(i) = v
Next v
End If
OneDRangeTo1DArray = arr
End Function
another possibilty
c = Application.Index(ws.Range("A2:A" & lRow).Value2, Application.Evaluate("transpose(row(1:" & lRow - 1 & "))"), 1)
A Variant IS a TYPE (similar to String, Long, Integer, Byte, Double). However, I am guessing you are trying to force a VARIABLE to be a DIFFERENT type (string?) and as part of an ARRAY?
If so, I think this should work for you. It creates an array starting at 0 with a maximum of the last row less two cells. If you wanted to transpose it, or make it multidimensional, just add another layer.
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ReDim c(lRow - 2) As String
'if you need two dimensioanl you could experiment with this:
'ReDim c(lRow - 2, 0) As String
Dim i As Long
For i = 0 To (lRow - 2)
c(i) = ws.Range("A2").Offset(i, 0).Value2
'OR if two dimenssional
'C(i,0) =
Next i
Because I was only after a 1D array, I ended up just creating a function to reuse based on Christian Buse's answer:
Public Function GetArrayFromVerticalRange(rng As Range) As Variant
If rng.Count > 1 Then
GetArrayFromVerticalRange = Application.Transpose(rng.Value2)
Else
Dim c(0) As Variant: c(0) = rng.Value2
GetArrayFromVerticalRange = c
End If
End Function
Used "Vertical" term to remind me to only pass in single column ranges! And could create a "Horizontal" version to use the transpose of the transpose
I am getting an error of "Subscript out of Range" when I'm trying to add the row value, of visible cells (minus the header) to the array. Below the code:
Dim Rng As Range
Dim r As Range
Dim i as Long
Dim arr() As Long
Set Rng = ActiveSheet.UsedRange.Resize(ActiveSheet.UsedRange.Rows.Count - 1, ActiveSheet.UsedRange.Columns.Count).Offset(1, 0).SpecialCells(xlCellTypeVisible)
i = 0
For Each r In Rng.Rows
'Debug.Print r.Row
arr(i) = r.Row
i = i + 1
Next
Am I forgetting something ?! I'm still new to VBA and more so, to arrays.
This function works fine...
I didn't get how you are calculating the range... but this output is coming out of the range only.. array is totally dynamic
Sub foo()
Dim Rng As Range
Dim r As Range
Dim i As Long
Dim arr() As Variant
Set Rng = ActiveSheet.UsedRange.Resize(ActiveSheet.UsedRange.Rows.Count - 1, ActiveSheet.UsedRange.Columns.Count).Offset(1, 0).SpecialCells(xlCellTypeVisible)
i = 1
For Each r In Rng.Rows
ReDim Preserve arr(i)
arr(i) = r.Row
Debug.Print arr(i)
i = i + 1
Next
End Sub
As already pointed out, you have to define the array. You can give it a fixed size when defining it (Dim arr(2) as Integer).
Dynamic ranges can be made with using ReDim. With Preserve it saves the values in the array when redefining the size. (Note: You can only ReDim the last dimension of an array)
The problem is that although you are declaring the array, you haven't initialised it with a size, so there are no elements in the array hence the subscript out of range.
Your code should read, note the other problem you will have is how you are trying to address the range, I have corrected below:
Dim Rng As Range, r As Range
Dim i as integer
Dim ary() as Long
Set Rng = ActiveSheet.UsedRange.Resize(ActiveSheet.UsedRange.Rows.Count - 1, ActiveSheet.UsedRange.Columns.Count).Offset(1, 0).SpecialCells(xlCellTypeVisible)
Redim ary(Rng.Rows.Count)
i = 0
For Each r In Rng.Rows
'Debug.Print r.Row
arr(i) = CLng(r.Row)
i = i + 1
Next
This is a tested and working example
I'm trying to match (90%) partial text string from a sheet column to another sheet column and bring end result to the master sheet column.
I found a VBA solution but I have some problems with that.
1) it's matching exact text
2) finding a problem to match two different sheet columns.
Please help me to sort this out.
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("BANK STATEMENT ENTRY").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
Range("F3:F" & TotalRows).Copy Destination:=Sheets("TEST").Range("A1")
'Go to the destination sheet
Sheets("TEST").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("INFO").UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value
End If
Next
End Sub
I have done a text mining project and I know you cannot use that approach, you have to break the strings into substrings and then analyze them. It will be a whole project, but you are lucky since I did it for you.
Let's simplify the problem and say that you have two ranges of strings and you want to find every similar strings between two groups. Also, you want to have a tolerance to minimize the matching pairs.
Assume ABCDE and 12BCD00. They have B, C, D, BC, CD and BCD in common. So the longest common substring is BCD which is 3 characters: 3/length of ABCDE(5) will be 60% similarity with the first string and 3/7=43% similarity. So if you can get a list of all those common substrings among all the strings in two ranges you can come up with a better list to filter and get what you want.
I wrote a bunch of functions. To use it easily, just copy and paste both groups of strings in one sheet and generate the final report on the same sheet too to understand how it works.
Function FuzzyFind, finds all of the common substrings and gives you 1st string from Group1/range1, 2nd string from group2/range2, common substring and percentages of similiarity for both strings. The good thing is you can tell the function how small you want your substrings e.g. in the previous example, if you say iMinCommonSubLength=3, it will only give you BCD, if you say iMinCommonSubLength=2 it will give you BC, CD and BCD and so on.
Use function Main. I also included a Test sub.
Functions:
Sub TestIt()
Call Main(ActiveSheet.Range("A1:A10"), ActiveSheet.Range("B1:B10"), 4, ActiveSheet.Range("D1"))
End Sub
Sub Main(rng1 As Range, rng2 As Range, iMinCommonSubLength As Integer, Optional rngReportUpperLeftCell As Range)
Dim arr() As Variant
Dim rngReport As Range
If rngReport Is Nothing Then Set rngReport = ActiveSheet.Range("A1")
arr = FuzzyFind(rng1, rng2, iMinCommonSubLength)
Set rngReport = rngReportUpperLeftCell.Resize(UBound(arr, 1), UBound(arr, 2))
rngReport.Value = arr
rngReport.Columns(1).NumberFormat = "#"
rngReport.Columns(2).NumberFormat = "#"
rngReport.Columns(3).NumberFormat = "#"
rngReport.Columns(4).NumberFormat = "0%"
rngReport.Columns(5).NumberFormat = "0%"
End Sub
Function GetCharacters(str As String) As Variant
Dim arr() As String
ReDim arr(Len(str) - 1)
For i = 1 To Len(str)
arr(i - 1) = Mid$(UCase(str), i, 1)
Next
GetCharacters = arr
End Function
Function GetIterations(iStringLength As Integer, iSubStringLength As Integer) As Integer
If iStringLength >= iSubStringLength Then
GetIterations = iStringLength - iSubStringLength + 1
Else
GetIterations = 0
End If
End Function
Function GetSubtrings(str As String, iSubLength As Integer) As Variant
Dim i As Integer
Dim count As Integer
Dim arr() As Variant
count = GetIterations(Len(str), iSubLength)
ReDim arr(1 To count)
For i = 1 To count
arr(i) = Mid(str, i, iSubLength)
Next i
GetSubtrings = arr()
End Function
Function GetLongestCommonSubStrings(str1 As String, str2 As String, iMinCommonSubLeng As Integer)
Dim i As Integer
Dim iLongestPossible As Integer
Dim iShortest As Integer
Dim arrSubs() As Variant
Dim arr1() As Variant
Dim arr2() As Variant
ReDim arrSubs(1 To 1)
'Longest possible common substring length is the smaller string's length
iLongestPossible = IIf(Len(str1) > Len(str2), Len(str2), Len(str1))
If iLongestPossible < iMinCommonSubLeng Then
'MsgBox "Minimum common substring length is larger than the shortest string." & _
' " You have to choose a smaller common length", , "Error"
Else
'We will try to find the first match of common substrings of two given strings, exit after the first match
For i = iLongestPossible To iMinCommonSubLeng Step -1
arr1 = GetSubtrings(str1, i)
arr2 = GetSubtrings(str2, i)
ReDim arrSubs(1 To 1)
arrSubs = GetCommonElement(arr1, arr2)
If arrSubs(1) <> "" Then Exit For 'if you want JUST THE LONGEST MATCH, comment out this line
Next i
End If
GetLongestCommonSubStrings = arrSubs
End Function
Function GetCommonElement(arr1() As Variant, arr2() As Variant) As Variant
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim arr() As Variant
count = 1
ReDim arr(1 To count)
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr2)
If arr1(i) = arr2(j) Then
ReDim Preserve arr(1 To count)
arr(count) = arr1(i)
count = count + 1
End If
Next j
Next i
GetCommonElement = arr
End Function
Function FuzzyFind(rng1 As Range, rng2 As Range, iMinCommonSubLength As Integer) As Variant
Dim count As Integer
Dim i As Integer
Dim arrSubs As Variant
Dim str1 As String
Dim str2 As String
Dim cell1 As Range
Dim cell2 As Range
Dim rngReport As Range
Dim arr() As Variant 'array of all cells that are partially matching, str1, str2, common string, percentage
count = 1
ReDim arr(1 To 5, 1 To count)
For Each cell1 In rng1
str1 = UCase(CStr(cell1.Value))
If str1 <> "" Then
For Each cell2 In rng2
str2 = UCase(CStr(cell2.Value))
If str2 <> "" Then
ReDim arrSubs(1 To 1)
arrSubs = GetLongestCommonSubStrings(str1, str2, iMinCommonSubLength)
If arrSubs(1) <> "" Then
For i = 1 To UBound(arrSubs)
arr(1, count) = cell1.Value
arr(2, count) = cell2.Value
arr(3, count) = arrSubs(i)
arr(4, count) = Len(arrSubs(i)) / Len(str1)
arr(5, count) = Len(arrSubs(i)) / Len(str2)
count = count + 1
ReDim Preserve arr(1 To 5, 1 To count)
Next i
End If
End If
Next cell2
End If
Next cell1
FuzzyFind = TransposeArray(arr)
End Function
Function TransposeArray(arr As Variant) As Variant
Dim arrTemp() As Variant
ReDim arrTemp(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
For a = LBound(arr, 2) To UBound(arr, 2)
For b = LBound(arr, 1) To UBound(arr, 1)
arrTemp(a, b) = arr(b, a)
Next b
Next a
TransposeArray = arrTemp
End Function
Don't forget to clear the sheet before generating new reports. Insert a table and use its autofilter to easily filter your stuff.
last but not least, don't forget to click on the check mark to announce this as the answer to your question.