I am just learning about using arrays and am a bit stuck on how to use arrays as an input for criteria in autofiltering. I would like to set an array with values and then filter an excel spreadsheet using those same values. I did the below code, but it keeps throwing up an error when I try to autofilter
Here is my code
Dim I As Integer
ReDim arr(1 to var) As Variant 'var is defined in a different function with a #
I = 1
For Each rngValue In rngValues.cells 'rngValues is defined in a different function
If rngValue ="c" then
arr(I)=rngValue.Offset(0,2)
End If
I = I +1
Next rngValue
arr(I) = "="
With ws1
.[A1].Autofilter Field:=1, Criteria1:=arr, operator:xlfiltervalues
End With
May be you could try this
fil = Split(Join(Application.Transpose(Range("list")))) ' here list is the name of the range
Range("A1").AutoFilter field:=1, Criteria1:=fil, Operator:=xlFilterValues 'it will only filter the list values
You can pass Range value to array faster by directly passing it like below:
Dim arr As Variant '~~> no need to re-dimension
arr = Application.Transpose(rngValues) '~~> Transpose produces 1D array
ws1.Range("A1").AutoFilter 1, arr, xlFilterValues
Note that rngValue should contain one dimension Range area only.
If however you want to stick with your logic; also to handle 2-dimension Range or non contiguous ranges, below should work:
Dim i As Long: i = 1
ReDim arr(1 to rngValues.Cells.Count)
For Each rngValue In rngValues
arr(i) = rngValue.Value
i = i + 1
Next
ws1.Range("A1").AutoFilter 1, arr, xlFilterValues
In any of the scenarios, make sure that the array produced to be used as filter is 1D.
Related
i have programmed a procedure to find all values of a list and store them in a collection. There are identical values but each value only should be stored once.
Here is my vba code:
For intRow = intStart To ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
k = 1
Do
If k > colData.count Then
colData.Add Trim(Cells(intRow, intClmn).Value)
Exit Do
ElseIf Trim(Cells(intRow, intClmn)) = colData.Item(k) Then
Exit Do
End If
k = k + 1
Loop
Next i
I wonder if there is a more efficient way to get those values though. Do you know a more efficient way to collect values of a list?
If I've understood then I would record copying and pasting the column to a blank worksheet, and using the Remove Duplicates feature on this area to result in a column of distinct values that you can iterate.
As the new (temporary) worksheet is blank other than the retained values, you could use UsedRange to iterate all its cells:
For rng In Sheets("TempSht").UsedRange
Next rng
or again use End(xlUp) (or xlDown).
Could even get the entire range into an array if appropriate:
Dim arr As Variant
arr = WorksheetFunction.Transpose(Range("A1:A3"))
I ommited declaration of intStart and intClmn as well as calculating their values.
You can use Dictionary object and operate with an array instead of cells.
You need to add a reference in order to use early binding, a great answer is already here. You need Microsoft Scripting Runtime reference.
Dim vArr(), i As Long, j As Long, DataRange As Range
'Dim intStart As Long, intClmn As Long
'intStart = 1: intClmn = 7
' Declaring and creating a dictionary (choose one and wisely)
'--------------------------------------------------------------
' Late binding
Dim iDict As Object
Set iDict = CreateObject("Scripting.Dictionary")
' Early binding (preferable, you need to enable reference)
'Dim iDict As Scripting.Dictionary
'Set iDict = New Scripting.Dictionary
'--------------------------------------------------------------
' Define range of your data (may vary, modify so it suits your needs)
With ActiveSheet
Set DataRange = .Range(.Cells(intStart, 1), _
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, intClmn))
End With
' Populate an array with trimmed values
' I'm not sure how productive it is comparing to calling Trim in a loop so..
' You're free to test it
vArr = Evaluate("IF(ROW(), TRIM(" & DataRange.Address & "))")
' Loop through array
For i = LBound(vArr, 1) To UBound(vArr, 1)
For j = LBound(vArr, 2) To UBound(vArr, 2)
' Add an item with the key of vArr(i, j),
' otherwise change an existing item with this key to vArr(i, j)
iDict(vArr(i, j)) = vArr(i, j)
Next j
Next i
Looping through two ranges in one variant variable.
I am trying to read two ranges together at the same time using one variant. I have two ranges A and B, and I am combining them. After combining these two ranges, I am using a variant to read it. My variant variable only reading column A and ignoring Column B. Any suggestion what I am doing wrong.
Dim rngText as Range, rngText2 as Range, results as Range, dText
Set rngText = wSheet3.Range(wSheet3.Range("A1"), wSheet3.Cells(Rows.Count, 1).End(xlUp))
Set rngText2 = wSheet3.Range(wSheet3.Range("B1"), wSheet3.Cells(Rows.Count, 2).End(xlUp))
Set results = Union(rngText, rngText2)
dText = results.Value
For i = 1 to Ubound(dText,1)
'other condition here....
Next i
For i = 1 to Ubound(dText,1)
This loop iterates the first dimension of dText, which is declared as an implicit Variant.
dText = results.Value
This assigns the Variant with a 2D array representing the result of the Union operation. Unless a Range is representing a single cell, Range.Value always returns a 2D array.
You need a nested loop to iterate both dimensions of your 2D array.
Dim currentRow As Long
For currentRow = 1 To UBound(dText, 1)
Dim currentCol As Long
For currentCol = 1 To UBound(dText, 2)
' do stuff
Next
Next
Depending on what you're trying to achieve, it might be better to only iterate rows, and have your loop body's logic get the column indices:
Dim currentRow As Long
For currentRow = 1 To UBound(dText, 1)
Debug.Print "Column A: " & dText(currentRow, 1), "Column B: " & dText(currentRow, 2)
Next
Note that the 2D array holds Variant values representing whatever value/type that's held in the cells: if a cell contains a number, the array index will point to some Variant/Double; if a cell contains a string, the array index will point to some Variant/String; if a cell contains an error, the array index will point to some Variant/Error - and that last point is critical: you'll want to validate that the cell value doesn't contain an error before you assume its type and do anything with it (e.g. the above string-concatenation would fail with run-time error 13 / "type mismatch" given a Variant/Error value in either column, because a String can't be compared to or otherwise converted [implicitly or explicitly] to an Error). This would be safer:
Dim currentRow As Long
For currentRow = 1 To UBound(dText, 1)
If Not IsError(dText(currentRow, 1) And Not IsError(dText(currentRow, 2)) Then
Debug.Print "Column A: " & dText(currentRow, 1), "Column B: " & dText(currentRow, 2)
End If
Next
I ended up defining another loop. That's how I did it, before i was trying to do it in one loop but didn't work.
Set rngText = wSheet3.Range(wSheet3.Range("A1"), wSheet3.Cells(Rows.Count, 1).End(xlUp))
Set rngText2 = wSheet3.Range(wSheet3.Range("B1"), wSheet3.Cells(Rows.Count, 2).End(xlUp))
dText = rngText.Value
dText2= rngText2.Value
For i = 1 to Ubound(dText,1)
'do stuff
Next i
'second loop
For ii = 1 to Ubound(dText2,1)
'do stuff
Next ii
I want to create a 2D variant array from data in a worksheet. The issue is The columns I want to use are not adjacent and the amount of elements exceeds 65,536. (the apparent limit for Application.Index() using an Array() as Arg3. How should I proceed?
I have an answer to this question that works for me. I have read a great deal on this topic and I am curious if anyone else has had significant success with any other methods, because they are out there.
One Very Fast Solution: .Evaluate()
Application.Index([Range/Array],[Row],[Column]) is an extremely useful function.
Answer:
Dim arr as Variant 'This is the array you want to create.
Dim varRows as Variant 'This will hold the rows want to index
Dim LastRow as Long 'This is the last row of data you are needing
LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'set the last row
varRows = Evaluate("row(1:" & LastRow & ")") 'Evaluate is the make or break here. You can modify your start row as well by changing the 1.
arr = Application.Index(Sheets("Sheet1").Cells, varRows, Array(1, 3, 5)) 'You can set your array to be any columns you want.
'arr will now be a 2D array arr(1 to varRows, 1 to 3) in this example.
This method is so very fast it is dumb. It beats the pants off of a For Loop.
I passed a Range in this example but an array can also be passed if you need to Slice out 1 or more columns into a new array
Slice columns from an existing array Of any Type!:
This creates a Variant array and variants are so easy to get and return to the sheet.
Dim arr as Variant 'This is the array you want to create.
Dim SmallerArr as Variant 'the new array
Dim varRows as Variant 'This will hold the rows want to index
Dim LastRow as Long 'This is the last row of data you are needing
LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'set the last row
varRows = Evaluate("row(1:" & LastRow & ")") 'Evaluate is the make or break here. You can modify your start row as well by changing the 1.
arr = Application.Index(Sheets("Sheet1").Cells, varRows, Array(1, 3, 5)) 'You can set your array to be any columns you want.
'read a single column into a new variant array
SmallerArr = Application.Index(arr, varRows, 1) 'You can set your array to be any columns you want.
'read multiple columns into a new variant array
SamllerArr = Application.Index(arr, varRows, Array(1, 2)) 'The columns must exist in arr or you will get an error.
Dim lngArr(1 To 100000, 1 To 3) As Long 'create 2D array of type long
'Fill array
For h = 1 To 3
For j = 1 To 100000
lngArr(j, h) = j * h
Next j
Next h
SamllerArr = Application.Index(lngArr, varRows, Array(1, 2)) 'The columns must
'we just turned a long array into a variant array!
'we can read it to the sheet without a For loop!
Read columns back to the sheet:
Dim arr as Variant 'This is the array you want to create.
Dim SmallerArr as Variant 'the new array
Dim varRows as Variant 'This will hold the rows want to index
Dim LastRow as Long 'This is the last row of data you are needing
LastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'set the last row
varRows = Evaluate("row(1:" & LastRow & ")") 'Evaluate is the make or break here. You can modify your start row as well by changing the 1.
arr = Application.Index(Sheets("Sheet1").Cells, varRows, Array(1, 3, 5)) 'You can set your array to be any columns you want.
'Read 1 column to the sheet
Sheets("Sheet2").Range("A1:A" & LastRow) = Application.Index(arr, varRows, 1) ' cange the range and column accordingly
'Read multiple columns to the sheet
Sheets("Sheet2").Range("A1:B" & LastRow) = Application.Index(arr, varRows, Array(1, 2))
Notes:
1) varRows can be modified to accept any position of elements.
2) In Excel 2013 at least, when using Index() without passing arrays as arguments for row/column, there does not appear to be any row limitations.
3A) All arrays created this way are 2D. Even if they are 1 column they are still 1 wide.
3B) Application.Transpose() has row limitations as well just in case you were trying it...
I am not quite sure how to interpret the question but here is a method (two variations) of doing what I guess is asked for. This can be expanded/automated/adjusted as desired.
Sub ForJoshua1()
' Say, you want 2 columns: "B:B", "H:H"
Dim vX(1 To 2) As Variant
vX(1) = Range("B:B")
vX(2) = Range("H:H")
End Sub
Sub ForJoshua2()
' Say, you want 2 columns: 2, 8
Dim vX(1 To 2) As Variant
vX(1) = Sheet1.Columns(2)
vX(2) = Sheet1.Columns(8)
End Sub
If you have an "a" in the cell "B12", for example, then
vX(1)(12,1) would equal "a"
I want to populate Array in VBA , using for each-loop but unable to do that
Dim MyArray() As Variant
Dim RowCounter As Integer
Dim ColCounter As Integer
Dim rCell As Range
Dim rRng As Range
Set rRng = Sheet1.Range("B10:Z97")
RowCounter = 0
ColCounter = 0
ReDim MyArray(rRng.Rows.Count, rRng.Columns.Count) 'Answer by #varocarbas
For Each rCol In rRng.Columns
For Each rCell In rCol.Rows
If IsNumeric(rCell.Value) And (Not (IsEmpty(rCell.Value))) And (Len(rCell.Value) <> 0) Then
'ReDim Preserve MyArray(RowCounter, ColCounter) -- Old Logic which cause Error
MyArray(RowCounter, ColCounter) = rCell.Value
RowCounter = RowCounter + 1
Else
'Debug.Print rCell.Value & " is not an Integer" & vbNewLine
End If
Next rCell
ColCounter = ColCounter + 1
RowCounter = 0
Next rCol
But ReDim Preserve MyArray(RowCounter, ColCounter) in this line I got subscript error , when ReDim Preserve MyArray(1, 0)
I want to read the value from excel sheet populate the array then do some calculation and update the value of Last Cell of the each Column in Excel from by Calculate Value of the Excel.
Update in code
Function RunSquareOfVariance(temperature As Integer, cellValue As Variant) As Double
RunSquareOfVariance = "=IF((" & temperature + cellValue & ")<0,0,(" & temperature + cellValue & "))*IF((" & temperature + cellValue & ")<0,0,(" & temperature + cellValue & "))"
End Function
If within the code I change the bellow line
MyArray(RowCounter, ColCounter) = RunSquareOfVariance(StantardTemperature, rCell.Value)
Now within MyArray(0,0) Value store As =IF((-16.8)<0,0,(-16.8))*IF((-16.8)<0,0,(-16.8))
But I want to store the value of the formula Withing MyArray(0,0) = ValueOftheFormula
As far as I can remember you can change size ONLY of the last array dimension.
To be sure I've just checked and it's true. According to MSDN:
If you use the Preserve keyword, you can resize only the last array
dimension and you can't change the number of dimensions at all.
I don't know the ultimate goal of your sub therefore is difficult to suggest any changes. However, you could consider working with array of arrays. Syntax of such solution works as follows:
Dim arrA() As Variant
Dim arrB() As Variant
...
ReDim Preserve arrA(RowCounter)
ReDim Preserve arrB(ColCounter)
...
arrA(RowCounter) = x
arrB(ColCounter) = y
...
Dim arrAB
arrAB = Array(arrA, arrB)
...
'to get elements of array you need to call it in this way:
arrAB(0)(RowCounter) >> to get x
arrAB(1)(ColCounter) >> to get y
There are some disadvantages of such solution but could be useful in other situation.
You could do simply:
Dim rng As Range
Dim myArray() As Variant
Set rRng = Sheet1.Range("B10:Z97")
myArray = rRng.Value
You will also need to For Each rCell In rRng.Rows instead of For Each rCell In rCol.Rows. Otherwise, like Kaz says, you can only resize the last dimension of an array.
OK Problem solved
MyArray(RowCounter, ColCounter) = Application.Evaluate
(
RunSquareOfVariance(StantardTemperature, rCell.Value)
)
I can see you have found a solution for your issue. For future reference, I would like to add an alternative way of going about this.
In particular, I agree with #DavidZemens ’s approach on copying the range values to a variant array directly. It is a very elegant, simple and efficient solution. The only tricky part is when there are empty or non-numeric cells in the range you are looking, and you do not want to insert these values. A modification of David’s approach would work in case some of the values you are copying are not numbers.
Sub CopyNumbersToArray()
Dim var As Variant, rng As Range
' Grab the numeric values of the range only. Checking if cell is empty or
' if it has a positive length is not needed
Set rng = Range("B3:K3").SpecialCells(xlCellTypeConstants, xlNumbers)
' Copy the numbers. Note that var=rng.value will not work if rng is not contiguous
rng.Copy
' Paste the numbers temporarily to a range that you do not use
Range("A10000").Resize(1, rng.Count).PasteSpecial xlPasteValues
' Set rng object to point to that range
Set rng = Range(Cells(10000, 1), Cells(10000, rng.Count))
' Store the values that you need in a variant array
var = rng.Value
' Clear the contents of the temporary range
rng.ClearContents
End Sub
For more than 2 dimensions, jagged arrays is probably a good way to go (as suggested by #KazJaw)
I have a column of cells whose values are something like this:
a
a
b
b
c
c
c
c
d
e
f
f
etc.
I'm looking to take the non-duplicated values and paste them into a new column. My pseudocode for this is as follows:
ActiveSheet.Range("a1").End(xlDown).Select
aend = Selection.Row
for acol= 1 to aend
ActiveSheet.Range("b1").End(xlDown).Select
bend = Selection.Row
'if Cells(1,acol).Value <> any of the values in the range Cells(2,1).Value
'to Cells(2,bend).Value, then add the value of Cells(1,acol) to the end of
'column b.
Does my logic in this make sense? I'm not sure how to code the commented portion. If this isn't the most efficient way to do it, could someone suggest a better way? Thanks so much!
Depending on which version of Excel you are using, you can use some built-in Excel functionality to obtain what you want- the whole solution depends on your level of skill with VBA.
Excel 2003:
You can use the Advancedfilter method (documentation) of your range to obtain the unique values and copy them to your target area. Example:
With ActiveSheet
.Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B1"), Unique:=True
End With
Where B1 is the first cell of the column you wish to copy the unique values to. The only problem with this method is that the first row of the source column ("A1") will be copied to the target range even if it is duplicated. This is because the AdvancedFilter method assumes that the first row is a header.
Therefore, adding an additional code line we have:
With ActiveSheet
.Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B1"), Unique:=True
.Range("B1").Delete Shift:=xlShiftUp
End With
Excel 2007 / 2010:
You can use the same method as above, or use the RemoveDuplicates method (documentation). This is similar to the AdvancedFilter method, except that RemoveDuplicates works in-place, which means you need to make a duplicate of your source column and then perform the filtering, for example:
With ActiveSheet
.Range("A1", .Range("A1").End(xlDown)).Copy Destination:=.Range("B1")
.Range("B1", .Range("B1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
End With
The final parameter Header controls whether the first cell of the source data is copied to the destination (if it's set to true then the method similarly to the AdvancedFilter method).
If you're after a "purer" method, then you can use a VBA Collection or dictionary - I am sure that someone else will offer a solution with this.
I use a collection, which can't have duplicate keys, to get the unique items from a list. Try to add each item to a collection and ignore the errors when there's a duplicate key. Then you'll have a collection with a subset of unique values
Sub MakeUnique()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
'Put the data in an array
vaData = Sheet1.Range("A1:A12").Value
'Create a new collection
Set colUnique = New Collection
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
'Collections can't have duplicate keys, so try to
'add each item to the collection ignoring errors.
'Only unique items will be added
On Error Resume Next
colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
On Error GoTo 0
Next i
'size an array to write out to the sheet
ReDim aOutput(1 To colUnique.Count, 1 To 1)
'Loop through the collection and fill the output array
For i = 1 To colUnique.Count
aOutput(i, 1) = colUnique.Item(i)
Next i
'Write the unique values to column B
Sheet1.Range("B1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
For completeness, I'm posting the Scripting.Dictionary method: it's the commonest alternative to using a VBA.Collection and it avoids the need to rely on error-handling in normal operation.
A VBA Function using the Scripting.Dictionary Object to Return Unique Values from an Excel Range Containing Duplicates:
Option Explicit
' Author: Nigel Heffernan
' May 2012 http://excellerando.blogspot.com
' **** THIS CODE IS IN THE PUBLIC DOMAIN ****
'
' You are advised to segregate this code from
' any proprietary or commercially-confidential
' source code, and to label it clearly. If you
' fail do do so, there is a risk that you will
' impair your right to assert ownership of any
' intellectual property embedded in your work,
' or impair your employers or clients' ability
' to do so if the intellectual property rights
' in your work have been assigned to them.
'
Public Function UniqueValues(SourceData As Excel.Range, _
Optional Compare As VbCompareMethod = vbBinaryCompare _
) As Variant
Application.Volatile False
' Takes a range of values and returns a single-column array of unique items.
' The returned array is the expected data structure for Excel.Range.Value():
' a 1-based 2-Dimensional Array with dimensions 1 to RowCount, 1 to ColCount
' All values in the source are treated as text, and uniqueness is determined
' by case-sensitive comparison. To change this, set the Compare parameter to
' to 1, the value of the VbCompareMethod enumerated constant 'VbTextCompare'
' Error values in cells are returned as "#ERROR" with no further comparison.
' Empty or null cells are ignored: they do not appear in the returned array.
Dim i As Long, j As Long, k As Long
Dim oSubRange As Excel.Range
Dim arrSubRng As Variant
Dim arrOutput As Variant
Dim strKey As String
Dim arrKeys As Variant
Dim dicUnique As Object
' Note the late-binding as 'object' - best practice is to create a reference
' to the Windows Scripting Runtime: this allows you to declare dictUnique as
' Dim dictUnique As Scripting.Dictionary and instantiate it using the 'NEW'
' keyword instead of CreateObject, giving slightly better speed & stability.
If SourceData Is Nothing Then
Exit Function
End If
If IsEmpty(SourceData) Then
Exit Function
End If
Set dicUnique = CreateObject("Scripting.Dictionary")
dicUnique.CompareMode = Compare
For Each oSubRange In SourceData.Areas ' handles noncontiguous ranges
'Use Worksheetfunction.countA(oSubRange) > 0 to ignore empty ranges
If oSubRange.Cells.Count = 1 Then
ReDim arrSubRng(1 To 1, 1 To 1)
arrSubRng(1, 1) = oSubRange.Cells(1, 1).Value
Else
arrSubRng = oSubRange.Value
End If
For i = LBound(arrSubRng, 1) To UBound(arrSubRng, 1)
For j = LBound(arrSubRng, 2) To UBound(arrSubRng, 2)
If IsError(arrSubRng(i, j)) Then
dicUnique("#ERROR") = vbNullString
ElseIf IsEmpty(arrSubRng(i, j)) Then
' no action: empty cells are ignored
Else
' We use the error-tolerant behaviour of the Dictionary:
' If you query a key that doesn't exist, it adds the key
dicUnique(CStr(arrSubRng(i, j))) = vbNullString
End If
Next j
Next i
Erase arrSubRng
Next oSubRange
If dicUnique.Count = 0 Then
UniqueValues = Empty
Else
arrKeys = dicUnique.keys
dicUnique.RemoveAll
ReDim arrOutput(1 To UBound(arrKeys) + 1, 1 To 1)
For k = LBound(arrKeys) To UBound(arrKeys)
arrOutput(k + 1, 1) = arrKeys(k)
Next k
Erase arrKeys
UniqueValues = arrOutput
Erase arrOutput
End If
Set dicUnique = Nothing
End Function
A couple of notes:
This is code for any Excel range, not just the single-column range you asked for.This function tolerates cells with errors, which are difficult to handle in VBA.This isn't Reddit: you can read the comments, they are an aid to understanding and generally beneficial to your sanity.
I would use a simple array, go through all the letters and check if the letter you are on is in the array:
Sub unique_column()
Dim data() As Variant 'array that will store all of the unique letters
c = 1
Range("A1").Select
Do While ActiveCell.Value <> ""
ReDim Preserve data(1 To c) As Variant
If IsInArray(ActiveCell.Value, data()) = False Then 'we are on a new unique letter and will add it to the array
data(c) = ActiveCell.Value
c = c + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
'now we can spit out the letters in the array into a new column
Range("B1").Value = "Unique letters:"
Dim x As Variant
Range("B2").Select
For Each x In data()
ActiveCell.Value = x
ActiveCell.Offset(1, 0).Select
Next x
Range("A1").Select
c = c - 1
killer = MsgBox("Processing complete!" & vbNewLine & c & "unique letters applied.", vbOKOnly)
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function