I have searched Google as well as the Stack for examples of what I am trying to accomplish below, and while there are some good examples out there that are similar; I am having a little trouble getting my code to work the way I need it to
In the table below we have a table with user input (with animal values) and a corresponding Group ID. What I am trying to do is find the unique values in the group ID column and cross check them with different arrays. The code I have now checks to see which arrays share the same unique values.
However, as you can probably tell from the image I have included, the code that I have finds ALL arrays that have unique values in common. This would include arrays where said unique values are a subset of a larger array. What I am trying to do is find the array with the exact same unique values, nothing more nothing less; and when there is a match; a certain sub is executed.
Tables and Arrays are shown below:
so the logic behind it would be as follows:
if array3 = arrayMain _ 'the array in the main table (orange
then
array3Query 'run sub linked to array 3
...
if array4 = arrayMain then
array4Query 'run query linke to array 4
...
if array5 = arrayMain then
array5query 'etc..
...
Below is the function I currently have:
Function UniqueVal(ByRef Arr1, ByRef Arr2)
If TypeOf Arr1 Is Range Then Arr1 = Arr1.Value2
If TypeOf Arr2 Is Range Then Arr2 = Arr2.Value2
Dim e, x, i As Long
With CreateObject("scripting.dictionary")
.CompareMode = 1
For Each e In Arr1
If Len(e) Then .Item(e) = Empty
Next
For Each e In Arr2
If .Exists(e) Then .Item(e) = 1
Next
x = Array(.Keys, .Items)
.RemoveAll
For i = 0 To UBound(x(0))
If x(1)(i) = 1 Then .Item(x(0)(i)) = Empty
Next
If .Count Then UniqueVal = .Keys
End With
End Function
Which in turn is called by the below procedure:
Sub iTestIntersection()
MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("D2:D5")), vbLf)
MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("F2:F7")), vbLf)
MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("F10:F13")), vbLf)
MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("D10:D12")), vbLf)
''''''
End Sub
Any suggestions on what I would need to add to the above function and or procedure to accomplish what I am attempting to do (minus the message box of course; just trying to run the sub linked to it :)
If Arr1 isn't an array, but only a single value it will pass that value into ArrTemp(0) then ReDim Arr1(0) turning it into an empty array and finally it passes the original value back into Arr1(0). There might be an easier/better way to do this, but I think this will work for you. (I set the dictionary up with a name so I could debug easier.)
Function UniqueVal(ByRef Arr1, ByRef Arr2)
Dim ArrTemp(0)
Dim e, x, i As Long
Dim xDictionary As Object
If TypeOf Arr1 Is Range Then Arr1 = Arr1.Value2
If TypeOf Arr2 Is Range Then Arr2 = Arr2.Value2
If TypeName(Arr1) <> "Variant()" Then
ArrTemp(0) = Arr1
ReDim Arr1(0)
Arr1(0) = ArrTemp(0)
End If
Set xDictionary = CreateObject("Scripting.Dictionary")
With xDictionary
.CompareMode = 1
For Each e In Arr1
If Len(e) Then .Item(e) = Empty
Next
For Each e In Arr2
If .Exists(e) Then
.Item(e) = 1
Else
.RemoveAll
UniqueVal = .Keys
Exit Function
End If
Next
x = Array(.Keys, .Items)
.RemoveAll
For i = 0 To UBound(x(0))
If x(1)(i) = 1 Then
.Item(x(0)(i)) = Empty
Else
.RemoveAll
UniqueVal = .Keys
Exit Function
End If
Next
If .Count Then UniqueVal = .Keys
End With
End Function
Related
I have an array an VBA
strname=[English,science,Social,English,Social,science,science,Social,English,,,]
I want to remove duplicates and empty values in this array and concatenate them.
Expected Output : English;science;Social
I tried with looping logic but it doesnt work
For i=0 to 10
if strname[i] <> "" then
if strname[i]= strname[i+1] then
tempstr=strname[i]
end i
end if
next
here it will check 0 with 1 , 1 with 2 like that.Am trying for proper solution
Please, try the next way:
Sub removeArrDuplAndEmpty()
Dim x As String, arr, i As Long, dict As Object
x = "English,science,Social,English,Social,science,science,Social,English,,,"
Set dict = CreateObject("Scripting.Dictionary")
arr = Split(x, ",") 'extract the array
For i = 0 To UBound(arr)
If arr(i) <> "" Then dict(arr(i)) = 1 'create unique keys for non blank array elements
Next
arr = dict.keys 'place back the dictionary keys in the initial array
Debug.Print Join(arr, ";") 'only to visually see the result
End Sub
The next version processes the string as you show it in your question:
Sub removeArrDuplAndEmptyBis()
Dim x As String, arr, i As Long, dict As Object
x = "[English,science,Social,English,Social,science,science,Social,English,,,]"
Set dict = CreateObject("Scripting.Dictionary")
arr = Split(left(Mid(x, 2), Len(Mid(x, 2)) - 1), ",")
For i = 0 To UBound(arr)
If arr(i) <> "" Then dict(arr(i)) = 1
Next i
arr = dict.keys
Debug.Print Join(arr, ",")
End Sub
This is what you want?
If not, please show an example of your real string and how it must look after processing...
So I have an Array called TagOptions - it contains numeric values according to a pervious if statement. In order to take out values I didn't want I gave the undesired values a place holder value of 0. I am now trying to filter out this value but can't find anything online that is helpful.
Will paste the entire function for context but more interested in just filtering out the placeholder zeros from my array.
Sorry if this is novice but I am very new to this:
Private Sub CommandButton4_Click()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("TEST")
lrow = sh.Cells(Rows.count, 1).End(xlUp).Row
Dim splitstring As String
Dim holder As String
Dim myarray() As String
Dim strArrayNumber() As Integer
Dim strArrayTag() As String
Dim TagOptions() As Integer
Dim TagOptions2() As Integer
ReDim strArrayNumber(1 To lrow) As Integer
ReDim strArrayTag(1 To lrow) As String
'Initial for loop splitting tags and removing any tags with text (MV-4005A)
'Transfering those remaining tag numbers into array if they match equip selected
For a = 1 To lrow
If sh.Cells(a, 1).Value <> vbNullString Then
splitstring = sh.Cells(a, 1).Value
myarray = Split(splitstring, "-")
strArrayTag(a) = myarray(0)
End If
If IsNumeric(myarray(1)) = False Then
myarray(1) = 0
End If
If strArrayTag(a) = TagNumber1.Value Then 'Only stored if has selected Equipment tag
strArrayNumber(a) = myarray(1)
End If
Next a
'Sort Created Array
Quicksort strArrayNumber, LBound(strArrayNumber), UBound(strArrayNumber)
ReDim TagOptions(1000 To 2000) As Integer
Dim j As Integer
For j = 1000 To 2000
For b = 1 To UBound(strArrayNumber)
If strArrayNumber(b) = j Then
TagOptions(j) = 0
Exit For
Else
TagOptions(j) = j
End If
Next b
sh.Cells(j, 8) = TagOptions(j)
Next j
Quicksort TagOptions, LBound(TagOptions), UBound(TagOptions)
For f = LBound(TagOptions) To UBound(TagOptions)
sh.Cells(f, 9) = TagOptions(f)
Next f
**TagOptions2 = Filter(TagOptions, "0", False, vbDatabaseCompare)**
Me.ComboBox1.List = TagOptions
End Sub
Thnak you in advance for any help.
tl;dr entire code, just note that VBA's Filter() function applied on a "flat" 1-dim array only executes a partial character search finding "0" also in strings like e.g. "10" or "205", what definitely isn't what you want to do :-;
Btw, if your initial array is a 2-dim array, there are number of answers at SO how to slice data from a 2-dim array and transpose or double transpose them to a 1-dim array needed as starting point.
Solving the actual core question how to filter out zero-digits
To succeed in filtering out zeros in a 1-dim array, simply use the following function via the Worksheetfunction FilterXML (available since vers. 2013+):
tagOptions = WorksheetFunction.FilterXML("<t><s>" & _
Join(tagOptions, "</s><s>") & "</s></t>", _
"//s[not(.='0')]")
resulting in a 1-based 2-dim array.
If you prefer, however to get a resulting 1-dim array instead, simply transpose it via tagOptions = Application.Transpose(tagOptions) or tagOptions = WorkSheetFunction.Transpose(tagOptions).
You can find an excellent overview at Extract substrings ... from FilterXML
I can't seem to find this problem addressed anywhere.
I need to declare a bunch of dynamic arrays as follow:
Dim list1 () as variant
Dim list2() as variant
Dim list3() as variant
...
Dim listN() as Variant
Each list is a one-dimensional dynamic array. However, I wouldn't know what "N" will be during the program. I want to make these "N" lists dynamic as well. I have tried two-dimensional dynamic arrays. But the "redim" statement requires both dimensions to be declared at the same time. In particular, I do this:
Dim BigList() as variant
...
Redim BigList(listNum, listLength)
To access/pass into a sub "list1", "list2" , "list3"..., calling "BigList(1)", "BigList(2)" gives me error. In particular, somewhere in my code, there is this portion:
sub ProcessList(byref listToProcess() as variant)
...
end sub
sub main()
...
call ProcessList(list1)
call ProcessList(list2)
...
call ProcessList(listN)
end sub
Now I can do a loop:
for i = 1 to N
Call ProcessList(list"i")
next i
This requires list"i" to be a one-dimensional dynamic array. So, after a redim BigList(listNum,listLength) and I do this:
for i = 1 to N
Call ProcessList(BigList(i)) 'i refers to listNum
next i
This gives me error "Incompatible type".
Here is one example of creating a Dictionary which is keyed to integer values (i.e., the N) and each value is initially an empty array.
You can then use something like the ExtendList function to resize those empty arrays as needed.
Sub foo()
Dim BigList As Object
Dim N As Long
Dim v as Variant
'Create an empty dictionary object
Set BigList = CreateObject("Scripting.Dictionary")
'Add N empty array to the dictionary:
N = 3
For i = 1 To N
BigList(i) = Array()
Next
'Resize one of the items in your BigList
BigList(2) = ExtendList(BigList(2), 1, 10)
v = BigList(2) 'Here you can examine v in the Locals window and see it is an array, of dimensions 1 x 10
End Sub
Function ExtendList(lst, a As Long, b As Long)
ReDim lst(a, b)
ExtendList = lst
End Function
On review of your edited question, I think you merely misunderstood how the ReDim statement works:
Redim BigList(listNum, listLength)
This re-dimensions the BigList based on the parameters listNum and listLength. It does not (as it seems you may have expected) create a list of arrays within BigList.
I think this might also work (untested, and remember arrays are zero-index):
ReDim Preserve BigList(listNum)
BigList(listNum) = Array()
ReDim BigList(listNum)(listSize)
I have been trying to figure this out for some time now. Originally I had searched Google and found some examples of (more or less) what I am trying to do, but seem to be stuck on the code I have thus far. Essentially I am trying to compare the unique variables between two arrays and return a result when there is a perfect match (if one possesses unique values there represent a subset of the other, this would not be a perfect match, all values and number of values would have to be identical.
From the code I have included below; if I compare one array [range("B2:b6") with values {1, 2, 3}] to a second array [(range("D10:D11") with values {1, 2}], I receive a positive match. Per what I am trying to do however (and value order doesn't matter) the only perfect match within an array of {1, 2, 3} would be a second array with values {1, 2, 3} also (or {3, 2, 1} as order doesn't matter).
I am guessing it is due to the type of array I am using and the fact that the lowerbound starts at 0. I could also be completely wrong. I have tried playing around with it without success.
Any Thoughts? Any suggestions are welcome. Thanks! (included pics with different values below)
Function UniqueVal(ByRef Arr1, ByRef Arr2)
If TypeOf Arr1 Is Range Then Arr1 = Arr1.Value2
If TypeOf Arr2 Is Range Then Arr2 = Arr2.Value2
Dim e, x, i As Long
With CreateObject("scripting.dictionary")
.CompareMode = 1
For Each e In Arr1
If Len(e) Then .Item(e) = Empty
Next
For Each e In Arr2
If .Exists(e) Then
.Item(e) = 1
Else
.RemoveAll
UniqueVal = .Keys
Exit Function
End If
Next
x = Array(.Keys, .Items)
.RemoveAll
For i = 0 To UBound(x(0))
If x(1)(i) = 1 Then .Item(x(0)(i)) = Empty
Next
If .Count Then UniqueVal = .Keys
End With
End Function
'and the below sub which calls the above function
Sub iTestIntersectionX()
array4 = Join(UniqueVal(Worksheets("arrayTest2").Range("B2:B6"), Worksheets("arrayTest2").Range("D10:D11")), vbLf)
Worksheets("arrayTest2").Range("H20").value = array4
If Worksheets("arrayTest2").Range("H20").value <> "" Then
MsgBox "Match Found!"
Else
MsgBox "No Match Found!"
End If
End Sub
This will return True if the two ranges passed in have the same set of unique values (in any order or frequency)
Function HaveSameValues(rng1 As Range, rng2 As Range)
Dim c As Range
For Each c In rng1.Cells
If Len(c.Value) > 0 And IsError(Application.Match(c.Value, rng2, 0)) Then
SameValues = False
Exit Function
End If
Next c
For Each c In rng2.Cells
If Len(c.Value) > 0 And IsError(Application.Match(c.Value, rng1, 0)) Then
SameValues = False
Exit Function
End If
Next c
SameValues = True
End Function
When a range is a continuous column, the question can be solved with this formula:
LET(Target;B2:B6;Reference;D10:D11;AND(IFNA(SORT(UNIQUE(FILTER(Target;Target<>"")))=SORT(UNIQUE(FILTER(Reference;Reference<>"")));FALSE)))
If the range is different than a 1-dimensional array, I would use this code:
Function HaveSameUniques(Target As Range, Reference As Range) As Boolean
Dim TargetUniques As New Collection
Dim ReferenceUniques As New Collection
Dim Cell As Range
HaveSameUniques = False ' return False by default; we can drop this line
On Error Resume Next
For Each Cell In Target
If Len(Cell) <> 0 Then
TargetUniques.Add Key:=Cell.Value, Item:=0
End If
Next Cell
For Each Cell In Reference
If Len(Cell) <> 0 Then
On Error Resume Next
TargetUniques.Add Key:=Cell.Value, Item:=0
If Err.Number = 0 Then Exit Function ' if Target doesn't have Cell.Value, then exit and return false
ReferenceUniques.Add Key:=Cell.Value, Item:=0
End If
Next Cell
If TargetUniques.Count = ReferenceUniques.Count then
HaveSameUniques = True
End If
End Function
There's a formula you can enter into a cell called VLOOKUP. It takes several parameters. It looks up the value of one cell in a list of cells and returns the value of the cell next to the matching cell in the list of cells.
I am experimenting with something:
There is a list with names, and what I would like to do, is to read the cell values in an array (this part works) than run a check for every cell in the worksheet and if a given cell is the same as a string inside an array, do something.
But unfortunatly I get the "type mismatch" error.
Ps. I know this doesn't make much sense and I could to that something inside the server function, but belive me I have my reasons. :-)
Edit: fixed a few things, now it looks like this (now I get the object doesn't support this property of method)
If it helps, you can also try it. You just need to add a cell with the name "Servers" and under it write some random words. Right now it should write in msgbox "ok" x times, where x is the number of rows you wrote in, under the cell, named "Servers"
1
'server name
Function server(ByVal issrvname As String)
Dim j As Integer
Dim c As Range
Dim x As Integer, y As Integer
For Each c In Sheets("Topology").UsedRange.Cells
Dim srvname() As String
j = 0
If c.Cells.Value = "Servers" Then
y = c.Column: x = c.Row + 1
Do Until IsEmpty(Cells(x, y))
ReDim Preserve srvname(0 To j) As String
srvname(j) = Cells(x, y).Value
x = x + 1
j = j + 1
Loop
End If
Next c
For Each c In Sheets("Topology").UsedRange.Cells
If IsInArray(c.Cell.Value, srvname) Then
issrvname = True
Else
issrvname = False
End If
Next c
End Function
2
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
3
Sub test()
Dim c As Range
For Each c In Sheets("Topology").UsedRange.Cells
If server(c) = True Then
MsgBox "ok"
End If
Next c
End Sub
I think you can condense your functions:
First you need to include your Array generating block to your main sub.
Including it in the Function server is slowing code execution because it needs to generate the array in every call of the server Function
Edit1: This is tried in tested now. I've re-written your function and improve your sub a bit.
Sub test()
Dim j As Integer
Dim c As Range, c1 As Range
Dim x As Integer, y As Integer
Dim i As Long '~~> added it just to check how many is shown in MsgBox
For Each c In Sheets("Topology").UsedRange.Cells
'~~> generate array if "Servers" is encountered
If c.Value = "Servers" Then
Dim srvname() As String
j = 0
y = c.Column: x = c.Row + 1
With Sheets("Topology").UsedRange
Do Until IsEmpty(.Cells(x, y))
ReDim Preserve srvname(j)
srvname(j) = .Cells(x, y).Value
x = x + 1
j = j + 1
Loop
End With
'~~> use the generated Array of values here
i = 1
For Each c1 In Sheets("Topology").UsedRange.Cells
If IsInArray(c1.Value, srvname) Then
MsgBox "ok" & i
i = i + 1
End If
Next c1
End If
Next c
End Sub
Here's the new function: (actually, you don't need it, you can call the Match function directly in main Sub)
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Maybe you do this just for testing? I just thought that the sheet you use to generate the array must be different from the sheet you want to compare the server names.
I think it might be that you define c as a range in Test, but call server with c when server is expecting a boolean.