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
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
This is my logic
arr(1,2,3,4,5,6,7,8,9)
arr1(3,4,5)
arr2(2,0)
arr3(6,7,45,8,3)
(arr,arr1)....-> True
(arr,arr2)....-> False
(arr,arr3)....-> False
using word VBA, how to find that the value in arr2 must present in arr? if one of the value in arr2 didn't match with arr then it should come out of the particular array(Example: arr2(0,9)) and then start checking with next array(arr3). I want to compare one arr with multiple arrays**(arr1,arr2,arr3)**. I tried the below mentioned logic.
For j = 1 To UBound(arr1)
For k = 1 To UBound(arr2)
If arr1(j) = arr2(k) Then
\\.......
End If
Next
Next
Is this what you had in mind?
Sub TestMatched()
Dim Arr() As Variant
Arr = Array(33, 4, 15)
Debug.Print Matched(Arr)
End Sub
Private Function Matched(Arr2() As Variant) As Long
Dim Arr1() As Variant
Dim i As Long
Arr1 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
For i = LBound(Arr2) To UBound(Arr2)
If Not IsError(Application.Match(Arr2(i), Arr1, 0)) Then
Matched = Arr2(i)
Exit For
End If
Next i
End Function
Dear stackoverflow community
At work I have to write a macro which should be able to hide rows based on numbers in a column. Those can be multiple ones in one cell and the input should also allow to show more than one number at a time.
for example:
row 1: 20, 30, 15
row 2: 20
row 3: 13, 76
So if I enter 20, 30, it should only show rows 1 & 2)
I usually code with Java / c# and Im new to VBA, so Id really appreciate help:
My plan was to show a input box and split those numbers into an array.
Then i wanna go through each row with a for-Loop, in which i added two for each loops to check if any numbers equal. If not, hide row. If so, show and then i want to exit both for each loops and go to the next row. To exit nested loops, i tried using a do while boolean but it doesnt seem to work.
Right now it only shows the rows with all the input numbers (only row1 in example).
Sub SortingTest()
Dim numbers() As String
myNum = Application.InputBox("Enter BKPS (separate multiples by , )")
numbers = Split(myNum, ",", -1, compare)
'Userinput Vars
Dim row As Integer
row = 1
Dim saveNumber As String
'Looping Vars
Dim existingNum As String
Dim existingNumsArray() As String
Dim checkRows As Long
Dim saveElement As String
Dim done As Boolean
done = False
' Range("B3").Value = 10
' Saves the Input as Array:
For Each Element In numbers
saveNumber = Element
Cells(2, row).Value = saveNumber
row = row + 1
Next Element
Dim b As Integer
Do While done = False
For b = 1 To 100 'hardcoded, should be length of document. b == row;
existingNum = Cells(b, 3).Value
existingNumsArray = Split(existingNum, ",", -1, compare)
' loop thru input numbers
For Each Element In numbers
saveElement = Element
'loop thru given numbers
For Each inputElement In existingNumsArray
If saveElement <> inputElement Then
Rows(b).Hidden = True
ElseIf saveElement = inputElement Then
Rows(b).Hidden = False
done = True
Exit For
End If
Next
Next
Next
Loop
End Sub
Thank you very much for you answer. Yours hid all the rows, so i adjusted it to show them.
Option Explicit
Function ArrOr(a As Variant, b As Variant) As Boolean
Dim runner As Variant
ArrOr = True
If IsArray(a) Then
For Each runner In a
If ArrOr(runner, b) Then Exit Function
Next
Else
For Each runner In b
If Trim(a) = Trim(runner) Then Exit Function
Next
End If
ArrOr = False
End Function
Sub SortingBKPS()
Dim numbers As Variant, vars As Variant, i As Long, xRows As Range
numbers = Split(Application.InputBox("Enter BKPS (separate multiples by , )"), ",")
With Sheets("Sheet1")
vars = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)).Value2
For i = 2 To UBound(vars)
.Rows(i).EntireRow.Hidden = True
If ArrOr(Split(vars(i, 1), ","), numbers) Then
If xRows Is Nothing Then
Set xRows = .Rows(i)
Else
Set xRows = Union(xRows, .Rows(i))
End If
End If
Next
xRows.EntireRow.Hidden = False
End With
End Sub
By splitting it up it is very easy to do:
Option Explicit
Function ArrOr(a As Variant, b As Variant) As Boolean
Dim runner As Variant
ArrOr = True
If IsArray(a) Then
For Each runner In a
If ArrOr(runner, b) Then Exit Function
Next
Else
For Each runner In b
If Trim(a) = Trim(runner) Then Exit Function
Next
End If
ArrOr = False
End Function
Sub SortingTest()
Dim numbers As Variant, vars As Variant, i As Long, xRows As Range
numbers = Split(Application.InputBox("Enter BKPS (separate multiples by , )"), ",")
With Sheets("Sheet1")
vars = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)).Value2
For i = 1 To UBound(vars)
If ArrOr(Split(vars(i, 1), ","), numbers) Then
If xRows Is Nothing Then
Set xRows = .Rows(i)
Else
Set xRows = Union(xRows, .Rows(i))
End If
End If
Next
xRows.EntireRow.Hidden = True
End With
End Sub
by running this code line by line, it should be pretty much self explaining (also knowing you have already some knowledge in "coding")
Still, if you have any questions, just ask ;)
You can also do it the following way:
Sub SortingTest()
Dim numbers As Variant
Dim RangeCompare As Range
Dim MyRow As Integer
Dim NumFound As Boolean
numbers = Application.InputBox("Please,list the values in this format: " & _
vbCrLf & "{value, value, value, ...}", _
Default:="{#, #, #}", Type:=64)
For MyRow = 1 To Cells(Rows.Count, 1).End(xlUp).row
Set RangeCompare = Range(Cells(MyRow, 1), Cells(MyRow, Columns.Count).End(xlToLeft))
NumFound = False
For Each rCell In RangeCompare
For Each Element In numbers
If rCell = Element Then
NumFound = True
Exit For
End If
Next Element
If NumFound = True Then Exit For
Next rCell
If NumFound = False Then
Rows(MyRow).Hidden = True
End If
Next MyRow
End Sub
I think it's easy to understand but feel free to ask for explanation.
I am trying to compare two columns and if any similar value is there then I want to print that value in a third column. My code is like this:
Sub compare()
Dim arr1 As Range
Dim arr2 As Range
Set arr1 = Range("A1:A6")
Set arr2 = Range("B1:B6")
For Each x In arr1
For Each y In arr2
If x = y Then
Cells(C1).Value = 0
End If
Next y
Next x
End Sub
I am seeing:
Run Time error 1004 Application-defined or object defined error
It is tricky to use For Each when working with an array as you don't know where is in your array the data you are trying to work with. And furthermore, it'll only create duplicate values and you won't be able to interact with your array directly.
Plus, as your loops were sets, you would compare each cell in the first array to each one in the second array. You only need a common factor to loop on.
I added a few tests to avoid some basic issues :
Sub compare()
Dim arr1 As Range, _
arr2 As Range, _
Ws As Worksheet
With Ws
Set arr1 = .Range("A1:A6")
Set arr2 = .Range("B1:B6")
If arr1.Columns.Count > 1 Or arr2.Columns.Count > 1 Then
MsgBox "Too many columns for this simple compare", vbCritical + vbOKOnly
Exit Sub
Else
If arr1.Rows.Count <> arr2.Rows.Count Or arr1.Cells(1, 1).Row <> arr2.Cells(1, 1).Row Then
MsgBox "The ranges don't have the same amout of lines or don't start at the same line", vbCritical + vbOKOnly
Exit Sub
Else
For i = 1 To arr1.Rows.Count
If arr1.Cells(i, 1) <> arr2.Cells(i, 1) Then
Else
.Cells(arr1.Cells(1, 1).Row + 1, _
Max(arr1.Cells(1, 1).Columns, arr2.Cells(1, 1).Column)) _
.Offset(0, 1).Value = arr1.Cells(i, 1)
End If
Next i
End If
End If
End With
End Sub
The short answer is that you need to specify Row and Column when using Cells. The column is 3 for column C so the code to display the matching values should have looked something like this:-
Sub compare()
Dim arr1 As Range
Dim arr2 As Range
Dim count As Integer
Set arr1 = Range("A1:A6")
Set arr2 = Range("B1:B6")
For Each x In arr1
For Each y In arr2
If x = y Then
count = count + 1
Cells(count, 3) = x
End If
Next y
Next x
End Sub
Below one easy way, define one array with one range with 3 columns (two to compare and the 3th to write result)
Sub compare()
Dim Arr() As Variant
Arr = Range("A1:C6")
Dim R As Long
For R = 1 To UBound(Arr, 1)
If Arr(R, 1) = Arr(R, 2) Then
Arr(R, 3) = 0 'or the value of 1th column like arr(r,1)
End If
Next R
Range("A1:C6") = Arr
End Sub
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