In cells A1:A66000 I have the numbers 1, 2, ... 66000.
Sub addData()
Application.ScreenUpdating = False
Cells(1, 1) = 1
Cells(2, 1).Formula = "=A1+1"
Range(Range("A66000"), Range("A66000").End(xlUp)).Select
Selection.FillDown
Application.ScreenUpdating = True
End Sub
The following code loads the data into an array and finds the index of the number 2. It returns the correct result, 2.
Sub test()
Dim arr As Variant
arr = ArrayFromRange(Range("A1:A65536"))
MsgBox Application.WorksheetFunction.Match(2, Application.Index(arr, 0, 1), 0)
End Sub
However, changing the array size causes a Type Mismatch error due to the Index function.
Sub test()
Dim arr As Variant
arr = ArrayFromRange(Range("A1:A65537"))
MsgBox Application.WorksheetFunction.Match(2, Application.Index(arr, 0, 1), 0)
End Sub
How can I get around this? I'm using Excel 2007.
EDIT: I forgot to include this handy function that I'm calling
Function ArrayFromRange(rg As Range) As Variant()
'==============================================================================================
'Returns an array from a given range
' BG Feb 2013
'==============================================================================================
If (rg.Cells.Count = 1) Then
Dim arr(1 To 1, 1 To 1) As Variant
arr(1, 1) = rg.Value
ArrayFromRange = arr
Else
ArrayFromRange = rg ' Arr is now an allocated array
End If
End Function
Since there's a hard limit on the size of an array you can pass to WorksheetFunction.xxxx in VBA, you can instead leave the data on the sheet, and query it directly. This has the advantage of being much faster...
Sub test()
Dim arr As Variant, v, t, i As Long
Dim rng As Range
Set rng = ActiveSheet.Range("A1:A65536")
arr = rng.Value
'array-based approach
t = Timer
For i = 1 To 100
v = Application.WorksheetFunction.Match(i, Application.Index(arr, 0, 1), 0)
If i <= 5 Then Debug.Print v
Next i
Debug.Print Timer - t '>> 1.55 sec
'query worksheet directly
t = Timer
For i = 1 To 100
v = rng.Parent.Evaluate("MATCH(" & i & ", INDEX(" & rng.Address() & ", 0, 1), 0)")
If i < 5 Then Debug.Print v
Next i
Debug.Print Timer - t '>> 0.008 sec
End Sub
Related
The below is an extract from some code I have produced to automate some of the processes in my job. One element of the macro I produced is to remove any grades out of scope of my report. Since the out of scope grades are always changing, but the in scope grades are set, I decided to try and use an array. I have never used these before and I found some code online to use as a template, the problem is that the code seems to flag all grades as 'false' whether they are in the array or not. I have checked the range and column by changing delete to setting interior colour and this confirms the column and range is correct. I think the issue is that I have not properly linked the function with the code in the sub. Any advice or suggestions will be appreciated:
Sub SortData()
Dim firstrow As Long
Dim LastRow As Integer
Dim arrGrades As Variant, grd As Variant
arrGrades = Array("Range B", "Range C", "Range D Experienced", "Range D", "Range E", "Range E2", "SCS 1", "SCS 2", "SCS 3", "Student")
With Sheets("Active OoD")
.Select
firstrow = .UsedRange.Cells(1).Row
LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
Set rng = Range("H2", "H" & LastRow)
With rng
For i = .Rows.Count To 1 Step -1
If IsInArray(.Item(i), arrGrades) = False Then
.EntireRow.Delete
End If
Next i
End With
End With
End Sub
Function colNumeric(ColAlpha As String)
ColAlpha = UCase(ColAlpha)
If Len(ColAlpha) = 3 Then
Col_no = (Asc(Left(ColAlpha, 1)) - 64) * 26 * 26 + _
((Asc(Mid(ColAlpha, 2, 1)) - 64) - 1) * 26 + _
Asc(Right(ColAlpha, 1)) - 64
ElseIf Len(ColAlpha) = 2 Then
Col_no = (Asc(Left(ColAlpha, 1)) - 64) * 26 + _
(Asc(Right(ColAlpha, 1)) - 64)
Else
Col_no = Asc(Right(ColAlpha, 1)) - 64
End If
End Function
Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
'Function IsInArray(grd As Variant, arrGrades As Variant) As Boolean
'INPUT: Pass the function a value to search for and an array of values of any data type.
'OUTPUT: True if is in array, false otherwise
Dim element As Variant
On Error GoTo IsInArrayError: 'array is empty
For Each element In arr
If element = valToBeFound Then
IsInArray = True
Exit Function
End If
Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function
This line...
.EntireRow.Delete
...refers to the entire row for the entire range. So, for example, if Rng refers to the range H2:H10, EntireRow refers to $2:$10, hence everything gets deleted. Instead, try referring to the current row as follows...
.Item(i).EntireRow.Delete
I have a list with 3 variables in the sheet "Combined" in columns A; B; C.
The workbook contains 98 sheets, with those 3 variables still in A; B; C columns but in different combinations and with a fourth column which never repeats itself, as the sheets go on, which i need to bring in the "Combined" sheet, always adding another column for the next sheet I vlookup. : A B C + D(from the next sheet) + E(from the next sheet) and so on.
I have a UDF that Vlookups on 3 based on 3 criterias and a macro that cycles through the sheets and bring the values where i want them. The problem is, it's pretty slow, left it from yesterday and its on sheet 60. Any suggestions on improving it would greatly help, Thank you in advance!
Function ThreeVlookup(Table_Range As Range, Return_Col As Long, Col1_Fnd, Col2_Fnd, Col3_Fnd)
Dim rCheck As Range, bFound As Boolean, lLoop As Long
On Error Resume Next
Set rCheck = Table_Range.Columns(1).Cells(1, 1)
With WorksheetFunction
For lLoop = 1 To .CountIf(Table_Range.Columns(1), Col1_Fnd)
Set rCheck = Table_Range.Columns(1).Find(Col1_Fnd, rCheck, xlValues, xlWhole, xlNext, xlRows, False)
If UCase(rCheck(1, 2)) = UCase(Col2_Fnd) And UCase(rCheck(1, 3)) = UCase(Col3_Fnd) Then
bFound = True
Exit For
End If
Next lLoop
End With
If bFound = True Then
ThreeVlookup = rCheck(1, Return_Col)
Else
ThreeVlookup = ""
End If
End Function
Sub test()
Dim lookupVal1 As Range, lookupVal2 As Range, lookupVal3 As Range, myString As Variant, n&, u As Long
n = Sheets("Combined").[A:A].Cells.Find("*", , , , xlByRows, xlPrevious).Row
u = 4
For j = 2 To Worksheets.Count
For i = 1 To n
Set lookupVal1 = Sheets("Combined").Cells(i, 1)
Set lookupVal2 = Sheets("Combined").Cells(i, 2)
Set lookupVal3 = Sheets("Combined").Cells(i, 3)
myString = ThreeVlookup(Sheets(j).Range("A:D"), 4, lookupVal1, lookupVal2, lookupVal3)
Sheets("Combined").Cells(i, u) = myString
Next i
u = u + 1
Next j
End Sub
Use Arrays to speed it up, my friend! Load all your sheets (or just the current sheet in the loop) into an array in VBA's memory and do the .CountIf and .Find on arrayVar(row) instead of Table_Range.Columns(1).
You will be really surprised how much quicker it goes. Do it!
Here's a tutorial I like on arrays...
http://www.cpearson.com/excel/ArraysAndRanges.aspx
Here's a guy who speed-tested an application like yours...
https://fastexcel.wordpress.com/2011/10/26/match-vs-find-vs-variant-array-vba-performance-shootout/
The basics is like this:
Sub Play_With_Arrays()
Dim varArray() As Variant
Dim lngArray() As Long
ReDim varArray(1 To 1000)
ReDim lngArray(1 To 1000)
For A = 1 To 1000
lngArray(A) = A / 2
varArray(A) = A / 2 & " examples"
Next
searchterm = 345
For B = 1 To 1000
If lngArray(B) = searchterm Then
FoundRow = B
End If
Next
searchterm2 = "5 ex"
FoundStrRowCount = 0
For C = 1 To 1000
If InStr(1, varArray(C), searchterm2, vbBinaryCompare) Then
FoundStrRowCount = FoundStrRowCount + 1
End If
Next
MsgBox (FoundRow & " in long array and " & FoundStrRowCount & " in var array")
End Sub
Something like this should be much faster:
Public Function ThreeVLookup(ByVal arg_Col1LookupVal As Variant, _
ByVal arg_Col2LookupVal As Variant, _
ByVal arg_Col3LookupVal As Variant, _
ByVal arg_LookupTable As Range, _
ByVal arg_ReturnColumn As Long) _
As Variant
Dim rConstants As Range, rFormulas As Range
Dim rAdjustedTable As Range
Dim aTable As Variant
Dim i As Long
On Error Resume Next
Set rConstants = arg_LookupTable.SpecialCells(xlCellTypeConstants)
Set rFormulas = arg_LookupTable.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
Select Case (Not rConstants Is Nothing) + 2 * (Not rFormulas Is Nothing)
Case 0: ThreeVLookup = vbNullString
Exit Function
Case -1: Set rAdjustedTable = rConstants
Case -2: Set rAdjustedTable = rFormulas
Case -3: Set rAdjustedTable = Union(rConstants, rFormulas)
End Select
If WorksheetFunction.CountIfs(rAdjustedTable.Resize(, 1), arg_Col1LookupVal, rAdjustedTable.Resize(, 1).Offset(, 1), arg_Col2LookupVal, rAdjustedTable.Resize(, 1).Offset(, 2), arg_Col3LookupVal) = 0 Then
ThreeVLookup = vbNullString
Exit Function
End If
aTable = rAdjustedTable.Value
For i = LBound(aTable, 1) To UBound(aTable, 1)
If aTable(i, 1) = arg_Col1LookupVal And aTable(i, 2) = arg_Col2LookupVal And aTable(i, 3) = arg_Col3LookupVal Then
ThreeVLookup = aTable(i, arg_ReturnColumn)
Exit Function
End If
Next i
End Function
Sub tgr()
Dim wb As Workbook
Dim wsCombined As Worksheet
Dim ws As Worksheet
Dim aResults() As Variant
Dim aCombined As Variant
Dim i As Long, j As Long
Set wb = ActiveWorkbook
Set wsCombined = wb.Sheets("Combined")
aCombined = wsCombined.Range("A1").CurrentRegion.Value
ReDim aResults(1 To UBound(aCombined, 1) - LBound(aCombined, 1) + 1, 1 To wb.Sheets.Count - 1)
For i = LBound(aCombined, 1) To UBound(aCombined, 1)
j = 0
For Each ws In wb.Sheets
If ws.Name <> wsCombined.Name Then
j = j + 1
aResults(i, j) = ThreeVLookup(aCombined(i, 1), aCombined(i, 2), aCombined(i, 3), ws.Range("A:D"), 4)
End If
Next ws
Next i
wsCombined.Range("D1").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub
I have a requirement where in, I need to use the auto filter to filter the data first and then am using the advanced filter to get the Unique values alone. But the advanced filter doesn't take the auto filtered value alone. How do I use them together?
Here goes my code,
Colmz = WorksheetFunction.Match("RSDate", Sheets("RS_Report").Rows(1), 0)
ActiveSheet.ListObjects("RS").Range.AutoFilter Field:=Colmz, Criteria1:="YES"
ActiveSheet.Range("B1:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("CSRS").Range("B14"), Unique:=True
Kindly correct me and share your suggestions. Thanks
I would stick the unique values in an array - it's faster and less likely to break -
sub uniquearray()
Colmz = WorksheetFunction.Match("RSDate", Sheets("RS_Report").Rows(1), 0)
ActiveSheet.ListObjects("RS").Range.AutoFilter Field:=Colmz, Criteria1:="YES"
Call creatary(curary, Sheets("RS_Report"), Letter(Sheets("RS_Report"), "RSDate")): Call eliminateDuplicate(curary): Call BuildArrayWithoutBlankstwo(curary): Call Alphabetically_SortArray(curary)
For Each cell In curary
'do what you need to do with the unique array list
Next cell
end sub
Function creatary(ary As Variant, sh As Worksheet, ltr As String)
Dim x, y, rng As Range
ReDim ary(0)
Set rng = sh.Range(ltr & "2:" & ltr & sh.Range("A1000000").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
x = 0
For Each y In rng
If Not Application.IsError(y) Then
If Not IsNumeric(y) Then
ary(x) = y
End If
x = x + 1
ReDim Preserve ary(x)
End If
Next y
End Function
Function BuildArrayWithoutBlankstwo(ary As Variant)
Dim AryFromRange() As Variant, AryNoBlanks() As Variant
Dim Counter As Long, NoBlankSize As Long
'set references and initialize up-front
ReDim AryNoBlanks(0 To 0)
NoBlankSize = 0
'load the range into array
AryFromRange = ary
'loop through the array from the range, adding
'to the no-blank array as we go
For Counter = LBound(AryFromRange) To UBound(AryFromRange)
If ary(Counter) <> 0 Then
NoBlankSize = NoBlankSize + 1
AryNoBlanks(UBound(AryNoBlanks)) = ary(Counter)
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) + 1)
End If
Next Counter
'remove that pesky empty array field at the end
If UBound(AryNoBlanks) > 0 Then
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) - 1)
End If
'debug for reference
ary = AryNoBlanks
End Function
Function eliminateDuplicate(ary As Variant) As Variant
Dim aryNoDup(), dupArrIndex, i, dupBool, j
dupArrIndex = -1
For i = LBound(ary) To UBound(ary)
dupBool = False
For j = LBound(ary) To i
If ary(i) = ary(j) And Not i = j Then
dupBool = True
End If
Next j
If dupBool = False Then
dupArrIndex = dupArrIndex + 1
ReDim Preserve aryNoDup(dupArrIndex)
aryNoDup(dupArrIndex) = ary(i)
End If
Next i
ary = aryNoDup
End Function
Function Alphabetically_SortArray(ary)
Dim myArray As Variant
Dim x As Long, y As Long
Dim TempTxt1 As String
Dim TempTxt2 As String
myArray = ary
'Alphabetize Sheet Names in Array List
For x = LBound(myArray) To UBound(myArray)
For y = x To UBound(myArray)
If UCase(myArray(y)) < UCase(myArray(x)) Then
TempTxt1 = myArray(x)
TempTxt2 = myArray(y)
myArray(x) = TempTxt2
myArray(y) = TempTxt1
End If
Next y
Next x
ary = myArray
End Function
Function Letter(oSheet As Worksheet, name As String, Optional num As Integer)
If num = 0 Then num = 1
Letter = Application.Match(name, oSheet.Rows(num), 0)
Letter = Split(Cells(, Letter).Address, "$")(1)
End Function
I want to print a list of eight numbers to the worksheet, but only if they are all unique.
An ideal code would be something along the lines of
If a <> b <> c Then
Rather than
If a <> b And a <> c And b <> c Then
Is this possible, given that the values are called from an array using the code following:
Cells(2, 8) = numarr(i)
Cells(2, 9) = numarr(j)
Cells(2, 10) = numarr(k)
Cells(2, 11) = numarr(l)
Cells(3, 8) = numarr(m)
Cells(3, 9) = numarr(n)
Cells(3, 10) = numarr(o)
Cells(3, 11) = numarr(p)
Thanks!
The quick and dirty way to do this is with a Dictionary, which requires a unique key. Just keep dumping numbers in from your array until you hit one that's already in the Dictionary. Just make it into a function and pass your array to it:
Private Function AllUnique(incoming As Variant) As Boolean
If Not IsArray(incoming) Then Err.Raise 13
Dim candidates As Scripting.Dictionary
Set candidates = New Scripting.Dictionary
Dim index As Long
For index = LBound(incoming) To UBound(incoming)
If candidates.Exists(incoming(index)) Then Exit Function
candidates.Add incoming(index), index
Next index
AllUnique = True
End Function
I am going to throw in the direct comparison method:
Public Function AreEqual(ParamArray values() As Variant) As Boolean
Dim i As Long, j As Long, N As Long
Dim x As Double
N = UBound(values) + 1
For i = 1 To N - 1
x = values(i - 1)
For j = i + 1 To N
If values(j - 1) <> x Then
AreEqual = False
Exit Function
End If
Next j
Next i
AreEqual = True
End Function
To be used as
If AreEqual(num1,num2,num3,...) then
...
End If
As a slight variation of the Collection answer given above by #ja72, this function should be able to take any set of simple values of any type and determine if they're all identical or not. (The exception to this being the fourth test line for Strings, in which the Collection key is not case-sensitive.) I'm taking advantage of the hashing algorithm for adding keys to a Collection to ensure unique-ness.
Option Explicit
Sub Test()
Debug.Print AllValuesIdentical(14, 14, 14, 14, 14, 14, 14, 14, 14) 'true
Debug.Print AllValuesIdentical(5, 5, 5, 5, 5, 3, 5, 5) 'false
Debug.Print AllValuesIdentical("go", "go", "go", "go") 'true
Debug.Print AllValuesIdentical("go", "go", "go", "GO") 'also true
Debug.Print AllValuesIdentical(283.14, 283.14, 283.14) 'true
End Sub
Function AllValuesIdentical(ParamArray vals() As Variant) As Boolean
Dim uniqueCheck As Collection
Dim val As Variant
Set uniqueCheck = New Collection
On Error Resume Next
For Each val In vals
uniqueCheck.Add val, CStr(val)
Next val
If uniqueCheck.Count = 1 Then
AllValuesIdentical = True
Else
AllValuesIdentical = False
End If
On Error GoTo 0
Set uniqueCheck = Nothing
End Function
I've written a macro that takes a 2 dimensional array, and "prints" it to equivalent cells in an excel workbook.
Is there a more elegant way to do this?
Sub PrintArray(Data, SheetName, StartRow, StartCol)
Dim Row As Integer
Dim Col As Integer
Row = StartRow
For i = LBound(Data, 1) To UBound(Data, 1)
Col = StartCol
For j = LBound(Data, 2) To UBound(Data, 2)
Sheets(SheetName).Cells(Row, Col).Value = Data(i, j)
Col = Col + 1
Next j
Row = Row + 1
Next i
End Sub
Sub Test()
Dim MyArray(1 To 3, 1 To 3)
MyArray(1, 1) = 24
MyArray(1, 2) = 21
MyArray(1, 3) = 253674
MyArray(2, 1) = "3/11/1999"
MyArray(2, 2) = 6.777777777
MyArray(2, 3) = "Test"
MyArray(3, 1) = 1345
MyArray(3, 2) = 42456
MyArray(3, 3) = 60
PrintArray MyArray, "Sheet1", 1, 1
End Sub
On the same theme as other answers, keeping it simple
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End Sub
Sub Test()
Dim MyArray() As Variant
ReDim MyArray(1 To 3, 1 To 3) ' make it flexible
' Fill array
' ...
PrintArray MyArray, ActiveWorkbook.Worksheets("Sheet1").[A1]
End Sub
Create a variant array (easiest by reading equivalent range in to a variant variable).
Then fill the array, and assign the array directly to the range.
Dim myArray As Variant
myArray = Range("blahblah")
Range("bingbing") = myArray
The variant array will end up as a 2-D matrix.
A more elegant way is to assign the whole array at once:
Sub PrintArray(Data, SheetName, StartRow, StartCol)
Dim Rng As Range
With Sheets(SheetName)
Set Rng = .Range(.Cells(StartRow, StartCol), _
.Cells(UBound(Data, 1) - LBound(Data, 1) + StartRow, _
UBound(Data, 2) - LBound(Data, 2) + StartCol))
End With
Rng.Value2 = Data
End Sub
But watch out: it only works up to a size of about 8,000 cells. Then Excel throws a strange error. The maximum size isn't fixed and differs very much from Excel installation to Excel installation.
As others have suggested, you can directly write a 2-dimensional array into a Range on sheet, however if your array is single-dimensional then you have two options:
Convert your 1D array into a 2D array first, then print it on sheet (as a Range).
Convert your 1D array into a string and print it in a single cell (as a String).
Here is an example depicting both options:
Sub PrintArrayIn1Cell(myArr As Variant, cell As Range)
cell = Join(myArr, ",")
End Sub
Sub PrintArrayAsRange(myArr As Variant, cell As Range)
cell.Resize(UBound(myArr, 1), UBound(myArr, 2)) = myArr
End Sub
Sub TestPrintArrayIntoSheet() '2dArrayToSheet
Dim arr As Variant
arr = Split("a b c", " ")
'Printing in ONE-CELL: To print all array-elements as a single string separated by comma (a,b,c):
PrintArrayIn1Cell arr, [A1]
'Printing in SEPARATE-CELLS: To print array-elements in separate cells:
Dim arr2D As Variant
arr2D = Application.WorksheetFunction.Transpose(arr) 'convert a 1D array into 2D array
PrintArrayAsRange arr2D, Range("B1:B3")
End Sub
Note: Transpose will render column-by-column output, to get row-by-row output transpose it again - hope that makes sense.
HTH
My tested version
Sub PrintArray(RowPrint, ColPrint, ArrayName, WorkSheetName)
Sheets(WorkSheetName).Range(Cells(RowPrint, ColPrint), _
Cells(RowPrint + UBound(ArrayName, 2) - 1, _
ColPrint + UBound(ArrayName, 1) - 1)) = _
WorksheetFunction.Transpose(ArrayName)
End Sub
You can define a Range, the size of your array and use it's value property:
Sub PrintArray(Data, SheetName As String, intStartRow As Integer, intStartCol As Integer)
Dim oWorksheet As Worksheet
Dim rngCopyTo As Range
Set oWorksheet = ActiveWorkbook.Worksheets(SheetName)
' size of array
Dim intEndRow As Integer
Dim intEndCol As Integer
intEndRow = UBound(Data, 1)
intEndCol = UBound(Data, 2)
Set rngCopyTo = oWorksheet.Range(oWorksheet.Cells(intStartRow, intStartCol), oWorksheet.Cells(intEndRow, intEndCol))
rngCopyTo.Value = Data
End Sub