I have found lots of methods to remove duplicates of a 1D array but could not find a 2D example.
In addition to that, I wonder if the fuction can "leave" an instance of the duplicate item instead of removing them all.
Is it possible to do it?
Example:
Sub Tests()
Dim Example()
Example(0,0) = "Apple"
Example(1,0) = "Apple"
Example(0,1) = "Pear"
Example(1,1) = "Orange"
End Sub
Remaining items would be: Apple, Pear and Orange
This is how I like to do it, using a separate array to hold the unique items. This prevents your loops from having to cycle through non unique items when trying to test them.
Sub Test()
Dim Example(1, 1) As String
Dim NoDups() As String
Dim I, II, III As Long
ReDim NoDups(UBound(Example, 1) * UBound(Example, 2))
For I = 0 To UBound(Example, 1)
For II = 0 To UBound(Example, 2)
For III = 0 To UBound(NoDups)
If NoDups(III) = Example(I, II) Then
Exit For
ElseIf NoDups(III) = "" Then
NoDups(III) = Example(I, II)
Exit For
End If
Next
Next
Next
End Sub
To work through a 2D array, do as you would with a 1D array, but with a 'width' loop inside of a 'height' loop.
ie:
for a = 1 to number_of_elements_in_first_dimension
for y = 1 to number_of_elements_in_second_dimension
initial_comparison_string = array(a,b)
for x = a to number_of_elements_in_first_dimension
for y = b + 1 to number_of_elements_in_second_dimension
if Initial_comparison_string = array(x,y) then array(x,y) = ""
next y
next x
next b
next a
This will run fairly slowly with a very large 2D array, but I think you'd have to do 2 nested loops like this to take each value and compare it against each value which appears later.
Related
I have a 2d array and would like to sort each row based on the final column. I have created a mergesort algorithm in VBScript (which is what I am going to use) that does the sorting for a single column. But I would like to sort every row based on the final column like this, where I want the rows to be sorted based on the last row.
Name | X value | Y value | Z value
R1 | 10 | 3 | 2
There is a code mentioned in this post that does sorting for single dimension array sorting (https://stackoverflow.com/a/10351062/17862830). I have tried editing this code to solve my problem by extracting the integer that I am comparing from the strings in the array (extracting 19 from "Name,0,0,0,0,19"). However, I am not sure why does the code not work well as compared to doing it as just pure integer.
'The merge function.
Public Function Merge(LeftArray, RightArray, Order)
'Declared variables
Dim FinalArray
Dim FinalArraySize
Dim i
Dim LArrayPosition
Dim RArrayPosition
'Variable initialization
LArrayPosition = 0
RArrayPosition = 0
'Calculate the expected size of the array based on the two smaller arrays.
FinalArraySize = UBound(LeftArray) + UBound(RightArray) + 1
ReDim FinalArray(FinalArraySize)
'This should go until we need to exit the function.
While True
'If we are done with all the values in the left array. Add the rest of the right array
'to the final array.
If LArrayPosition >= UBound(LeftArray)+1 Then
For i=RArrayPosition To UBound(RightArray)
FinalArray(LArrayPosition+i) = RightArray(i)
Next
Merge = FinalArray
Exit Function
'If we are done with all the values in the right array. Add the rest of the left array
'to the final array.
ElseIf RArrayPosition >= UBound(RightArray)+1 Then
For i=LArrayPosition To UBound(LeftArray)
FinalArray(i+RArrayPosition) = LeftArray(i)
Next
Merge = FinalArray
Exit Function
'For descending, if the current value of the left array is greater than the right array
'then add it to the final array. The position of the left array will then be incremented
'by one.
ElseIf getNumber(LeftArray(LArrayPosition)) > getNumber(RightArray(RArrayPosition)) And UCase(Order) = "DESC" Then'**
FinalArray(LArrayPosition+RArrayPosition) = LeftArray(LArrayPosition)
LArrayPosition = LArrayPosition + 1
'For ascending, if the current value of the left array is less than the right array
'then add it to the final array. The position of the left array will then be incremented
'by one.
ElseIf getNumber(LeftArray(LArrayPosition)) < getNumber(RightArray(RArrayPosition)) And UCase(Order) = "ASC" Then'**
FinalArray(LArrayPosition+RArrayPosition) = LeftArray(LArrayPosition)
LArrayPosition = LArrayPosition + 1
'For anything else that wasn't covered, add the current value of the right array to the
'final array.
Else
FinalArray(LArrayPosition+RArrayPosition) = RightArray(RArrayPosition)
RArrayPosition = RArrayPosition + 1
End If
Wend
End Function
'The main sort function.
Public Function Sort(ArrayToSort, Order)
'Variable declaration.
Dim i
Dim LeftArray
Dim Modifier
Dim RightArray
'Check to make sure the order parameter is okay.
If Not UCase(Order)="ASC" And Not UCase(Order)="DESC" Then
Exit Function
End If
'If the array is a singleton or 0 then it is sorted.
If UBound(ArrayToSort) <= 0 Then
Sort = ArrayToSort
Exit Function
End If
'Setting up the modifier to help us split the array effectively since the round
'functions aren't helpful in VBScript.
If UBound(ArrayToSort) Mod 2 = 0 Then
Modifier = 1
Else
Modifier = 0
End If
'Setup the arrays to about half the size of the main array.
ReDim LeftArray(Fix(UBound(ArrayToSort)/2))
ReDim RightArray(Fix(UBound(ArrayToSort)/2)-Modifier)
'Add the first half of the values to one array.
For i=0 To UBound(LeftArray)
LeftArray(i) = ArrayToSort(i)
Next
'Add the other half of the values to the other array.
For i=0 To UBound(RightArray)
RightArray(i) = ArrayToSort(i+Fix(UBound(ArrayToSort)/2)+1)
Next
'Merge the sorted arrays.
Sort = Merge(Sort(LeftArray, Order), Sort(RightArray, Order), Order)
End Function
Dim arr
arr = Array("R1,0,0,0,0,12","R1,0,0,0,0,1","R1,0,0,0,0,2","R1,0,0,0,0,124", "R1,0,0,0,0,150","R1,0,0,0,0,9756","R1,0,0,0,0,200","R1,0,0,0,0,14","R1,0,0,0,0,-124","R1,0,0,0,0,-12","R1,0,0,0,0,0")
Dim sortarr : sortarr = Sort(arr, "asc")
Dim secsortarr : secsortarr = Sort(sortarr, "asc")
For i=0 To UBound(secsortarr)
MsgBox(secsortarr(i))
Next
Function getNumber(row)
Dim holdarr
holdarr = Split(row, ",")
getnumber = holdarr(UBound(holdarr))
End Function
I am a beginner to VBScript and new to SO and i am trying to add Keys of a dictionary object to a dynamic array based on certain condition that an array should hold maximum cnt of 100 or less than 100 only.Please find the below code and explanation for more clarity.
Dim dict,dict1,str_nbr,cnt,arrtest2()
str_nbr = "9728"
Set dict = CreateObject("Scripting.Dictionary")
dict.Add "Returns","67"
dict.Add "Debit","59"
dict.Add "PSR_PQV","55"
dict.Add "GiftCard","54"
dict.Add "Sales","45"
dict.Add "Discounts","26"
dict.Add "WIP","25"
dict.Add "Pro","23"
dict.Add "Void","20"
dict.Add "Receipt","15"
dict.Add "Price","12"
dict.Add "Inquiry","6"
dictItems = dict.Items
dictKeys = dict.Keys
ABC = CreateTestArray(dictItems,arrtest2)
The issue i am facing is with function CreateTestArray().Please find the 2 Functions used Below,
Function CreateTestArray(dictObj,arrTest)
sum =0
arrcnt = 0
For i = 0 To ubound(dictObj)
val = dictObj(i)
'arrcnt = 0
Do
'arrcnt = 0
Total = sum + val
val1 = arrcnt + total
If (Total<=100) and (val1<=100)Then
ReDim preserve arrTest(i)
arrTest(0) = str_nbr
call AddItem(arrTest,dictKeys(i))
dict.remove(dictKeys(i))
arrcnt = val1
Exit do
else
Exit do
End If
'arrcnt = val1
Loop while (arrcnt<=100)
If arrcnt>95 and arrcnt<=100 Then
Exit for
End If
Next
CreateTestArray = arrTest
End Function
'####################################
'To add value to array
Function AddItem(arr, val)
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = val
AddItem = arr
End Function
'####################################
The purpose of the function CreateTestArray(dictObj,arrTest) is that it will iterate the Items of the dictionary object and sum with each other till the arrcnt <=100 and add it to a array and remove the added key to avoid duplicates when the function is called next time.For Example in the dictionary provided,if we sum the values of Returns,Discounts,Inquiry(67+26+6 = 99),Then arrcnt = 99 which is less than equal to 100 and more than 95 as per requirement.So i am trying to add the keys(Returns,Discounts,Inquiry) to a dynamic array,having **str_nbr at index '0' as per requirement and adding the keys (Returns,Discounts,Inquiry) subsequently to the same array.The output of the array i receive is like below:
**output:**
ABC(0) - 9728
ABC(1) - Returns
ABC(2) - EMPTY
ABC(3) - EMPTY
ABC(4) - EMPTY
ABC(5) - EMPTY
ABC(6) - Discounts
ABC(7) - EMPTY
ABC(8) - EMPTY
ABC(9) - EMPTY
ABC(10) - EMPTY
ABC(11) - EMPTY
ABC(12) - Inquiry
Please suggest a way or workaround to avoid the 'Empty' fields in the array without changing the remaining logic,I have tried many approaches to get this right but nothing worked out.My final output should be an array just having (9728,returns,discounts,inquiry) omiting the empty fields.Kindly help me out in acheiving this which will be really helpful to proceed further.Thanks in advance.
The problem line is:
ReDim preserve arrTest(i)
The array size is being updated unnecessarily.
You need to add str_nbr only once, as the first element.
if i = 0 Then
ReDim arrTest(0)
arrTest(0) = str_nbr
end if
Or move it before the for loop.
To clear the blanks from the array, you can create another array then copy the non-blank entries:
ABC = CreateTestArray(dictItems,arrtest2)
' get non-blank count
cnt = 0
for x=0 to ubound(ABC)
if ABC(x) <> "" then
cnt = cnt + 1
end if
next
' create new array
dim arr3()
ReDim arr3(cnt)
i = 0
for x=0 to ubound(ABC)
if ABC(x) <> "" then
arr3(i) = ABC(x)
i = i + 1
end if
next
' display new array
s=""
for x=0 to ubound(arr3)
s = s & arr3(x) & vbcrlf
next
msgbox s
Output
9728
Returns
Discounts
Inquiry
I have a Variant in VB6 with thousands of Strings.
I also have an array of fixed length.
I need to compare the contents of each and add the ones that match to a list.
if array(i) = variant(1,i) then
'add to list
End if
I cannot figure out how to iterate over both properly in order to compare, as the method I use to iterate over the Variant() stops after going through each item. So it never checks to see if it any item is equal to i+1 in the array.
Private Sub dp_Click()
Dim fArray
fArray = Array("a", "b", "c")
LstAPens.ListItems.Clear
LstUPens.ListItems.Clear
For x = 0 To UBound(fArray)
Dim i As Long, m As Integer
'Do Until batcharray(0, i) = "End"
' tmpArray(i) = UCase(batcharray(1, i))
'Loop
Do Until batcharray(0, i) = "End"
If (InStr(1, UCase(batcharray(1, i)), UCase(fArray(x))) > 0) Then
LstAPens.ListItems.Add
With LstAPens.ListItems(m + 1)
.SubItems(1) = batcharray(1, i) 'Tagname
End With
m = m + 1
End If
i=i+1
Loop
Next x
End Sub
I tried to convert the Variant to an array but it did not work.
The only item that is found is the first one in the array, then the Variant is no longer iterated over as it reached the end.
How can I iterate over the Variant called batchArray in this example, and compare it to the contents of an array?
This really isn't a Variant problem, it's just a looping/control variable issue.
Even though you have your DIM statement inside your main loop, VB does not treat that as a "redeclaration" and reset/reinitialize its value before your UNTIL loop. As a result, 'i' will increment to 1 and then retain its value between iterations of your outer loop, thus remaining stuck on the single value in batchArray and the iteration ceases.
Move the declaration outside the loop, reset it to 0 before the UNTIL loop, and see if that solves your problem:
Dim i as Long
For x = 0 To UBound(fArray)
Dim m As Integer
i = 0
Do Until batcharray(0, i) = "End"
If (InStr(1, UCase(batcharray(1, i)), UCase(fArray(x))) > 0) Then
LstAPens.ListItems.Add
With LstAPens.ListItems(m + 1)
.SubItems(1) = batcharray(1, i) 'Tagname
End With
m = m + 1
End If
i=i+1
Loop
Next x
I am trying to trap the changes that a user makes on a sheet.
I have my worksheet_change event setup but the issue is what if the Target.Range is larger than a single cell?
Basically, I need to evaluate each and every cell change to test for validity using a function. My issue is the Target.Range can be any size of course and the function to test for validity looks at the surrounding cells.
I was trying to trap the addresses of the changed cells using something like this:
i = 1
j = 1
For Each aCell In Target
DiffAddys(i, j) = aCell.Address
NewValues(i, j) = aCell.Value2
If i < Target.Rows.Count Then i = i + 1
If j < Target.Columns.Count Then j = j + 1
Next
That way I can trap the cells' address and then use aCell.Row or aCell.Column, etc. but this fails if the Target.Range is bigger than 2 columns since the i index grows faster than it should.
Is there anyway to find the position of "aCell" in the Target range as it is looped by the For Each? Or is it just best to trust that For Each always goes 1,1 1,2 1,3 2,1 2,2, etc.?
Any better methods? Maybe just copy the address of each aCell into a 1D array that is equal to rows*columns of the Target.Range that way the i/j indexes are irrelevant - and then process this 1D array instead of a 2D array?
Thanks,
BT
More info about what you need to do with the arrays and how you are doing it would help. But as for what you posted... Something like you suggested, using 1D arrays, should do the trick :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim DiffAddys() As String, NewValues() As Variant
Application.EnableEvents = False
ReDim DiffAddys(Target.Cells.Count)
ReDim NewValues(Target.Cells.Count)
i = 1 'it is generaly not recommended to start array indexes on 1
For Each aCell In Target.Cells
DiffAddys(i) = aCell.Address
NewValues(i) = aCell.Value2
i = i + 1
Next aCell
Application.EnableEvents = True
End Sub
Or you could put the aCell.Address and aCell.Value2 into one 2D array.
Thanks to all for the suggestions. I just went ahead and took my own advice and went with the 1D array to store the addresses of the changed cells.
If Range("aq" & Target.Row).Value <> "p" And Target.Cells.Count <= 1 Then
Range("aq" & Target.Row).Value = 1
Application.EnableEvents = True
Exit Sub
End If
Application.ScreenUpdating = False
ReDim OldValues(1 To (Target.Rows.Count * Target.Columns.Count))
ReDim NewValues(1 To (Target.Rows.Count * Target.Columns.Count))
ReDim DiffAddys(1 To (Target.Rows.Count * Target.Columns.Count))
i = 1
For Each aCell In Target
DiffAddys(i) = aCell.Address
NewValues(i) = aCell.Value2
If i < (Target.Rows.Count * Target.Columns.Count) Then i = i + 1
Next
Application.Undo 'turn back time
For i = 1 To UBound(NewValues, 1) 'rows
OldValues(i) = Sheet5.Range(DiffAddys(i)).Value
Next i
Here's what I'm trying to do:
Suppose that you have a dynamic array whose dimensions can be from 0x6 up to 10x6 (meaning we can have rows anywhere from 0 to 10, but columns are always 6). I have been desperately trying to create a function (and then bind it to a macro) that will use as argument this first array, and will create a second array as output, whose elements will be the returns of the first array. For example, if we have the simple case of 1x6, then the output array's elements are five and in each case are given by the formula (x_i+1 - x_i)/x_i, i=1, 2, ..., 6. Additionally, the function must be able to bypass any missing values from the input array and ignore the corresponding non-existent return values. The entire thing must be done in VBA script.
It's been two days since I have been searching frantically for some help, but the problem is that I have no idea whatsoever about programming in VBA (I usually use other languages like MATLAB or Mathematica) so this is extremely hard for me. Any solutions that I have found I wasn't able to put together and achieve my goal. Any help is greatly appreciated.
Because you provided no code, I cannot determine exactly what you want to do, but here is an example of passing an array and returning an array that you should be able to extrapolate.
Edit: Just for fun, updated this to work for up to 3 dimensional arrays.
Public Sub Test()
'Defines testArray as Variant 0 to 10
Dim testArray(0 To 1, 0 To 6) As Long
Dim returnArray() As Long
Dim i As Long
Debug.Print UBound(testArray, 2)
'Populates testArray with Longs
For i = 0 To UBound(testArray, 1)
For j = 0 To UBound(testArray, 2)
testArray(i, j) = (i + j) * 2
Next
Next
'Passes testArray and returns ParseArray
returnArray = addOne(testArray)
End Sub
Public Function addOne(arrValues() As Long) As Variant
Dim arrCopy() As Long
Dim dimensionNum As Long, ErrorCheck As Long
On Error Resume Next
For dimensionNum = 1 To 60000
ErrorCheck = LBound(arrValues, dimensionNum)
If Err.Number <> 0 Then
dimensionNum = dimensionNum - 1
Exit For
End If
Next
Dim i As Long, j As Long, k As Long
'Copies passed array to avoid updating passed array directly
arrCopy = arrValues
'Adds 1 to each element of the array.
If dimensionNum = 1 Then
For i = LBound(arrCopy) To UBound(arrCopy)
arrCopy(i) = arrCopy(i) + 1
Next
ElseIf dimensionNum = 2 Then
For i = LBound(arrCopy) To UBound(arrCopy)
For j = LBound(arrCopy, 2) To UBound(arrCopy, 2)
arrCopy(i, j) = arrCopy(i, j) + 1
Next
Next
ElseIf dimensionNum = 3 Then
For i = LBound(arrCopy) To UBound(arrCopy)
For j = LBound(arrCopy, 2) To UBound(arrCopy, 2)
For k = LBound(arrCopy, 3) To UBound(arrCopy, 3)
arrCopy(i, j, k) = arrCopy(i, j, k) + 1
Next
Next
Next
Else
MsgBox "Add function only works for three dimensions or fewer arrays"
End If
addOne = arrCopy
End Function