Vlookup without repetition using vba on excel - arrays

I am trying to put in place a macro that allows me to match identical entry from one table to another. The tricky part is that if a match is found, it cannot be repeated. The way I theorized it is kind of elementary, however it is the only way I can think of it given my still limited knowledge in VBA.
The structure
Both tables need to be first filtered in order to allow the non-repetition condition.
Store the searching values as arrays in order to speed up the process of the macro
Match the entries to search with the ones from the targeted table in order to find matches. This is done with the in-application function MATCH. The MATCH function returns the cell where the match is situated, this is useful as it constantly shift the range in order to not repeate the same value all the time.
After calculating the shifting range, I use a VLookup function in order to return the second entry.
Unfortunately, the macro is incomplete. I cannot find a way to constantly shift the range without compromising the mechanism. The problem resides in the shifting range that is not created correctly to shift after each match.
Desired result
In the below image the desired result would be to check if all items in the left table are in the right table. Take item A, I need to find two item As. I have in the right column a first item A with value 17 and a second item A with value 81. If I do not find any value I have nothing, as it is the case of Ds and E. If instead I have less entries in the left table (as it is for the case of entry L) then I need to return all values of Entry L: 96; 77; 40.
Sub Matching11()
ThisWorkbook.Activate
Worksheets.add
Worksheets("Test4").Range("A1:T110").copy Destination:=ActiveSheet.Range("A1")
With ActiveSheet
Dim Search_Array As Variant
Search_Array = Range("C2", Range("C1").End(xlDown)) 'use this array to loop through the value to search for
Dim Target_MatchValue As Integer
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
counter = 0
n = 0
Target_MatchValue = 0
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range("H2:H200"), 0) - 1 'change C column with the range where you will have the tyres you need search for
Set Target_Range = .Range(.Cells(2 + n, 8), .Cells(1000, 9)) 'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
'If arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) Is Nothing Then GoTo NextCounter 'I used Vlookup in order to return the value set in the second column of the targetted table. As alternative, I think I could just use offset since I previously used MQTCH
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False)
If IsError(arr) Then
GoTo NextCounter
Else
.Range(Cells(1 + counter, 6), Cells(1 + counter, 6)).value = arr 'Return the value of the array in this cell
End If
Target_Range.Select
If Target_MatchValue = 0 Then
n = n + 1
ElseIf Target_MatchValue > 0 Then
n = n + Target_MatchValue
End If
.Range(Cells(1 + counter, 5), Cells(1 + counter, 5)).value = Search_Array(counter, 1) 'Return the value of the array in this cell
Next counter
NextCounter:
Next counter
End With
End Sub

Well, Let's see if this helps you out and probably you can adapt it to your needs.
I replied your data like this:
The macro will create a list in columns H:I like the right table of your image. The macro will always delete any previous result. My macro works on standard ranges, is not designed to work on tables (ListObjects in VBA), but you can easily adapt it to your needs.
Sub CREATE_LIST()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim MyRange As Range
Dim rng As Range
Dim i As Long
'we clear previous list
Columns("H:I").Delete
'we add data
Range("H1").Value = "Target"
Range("I1").Value = "Return"
LastRow = Range("C" & Rows.Count).End(xlUp).Row 'Last row of column C, where data is.
Set MyRange = Range("D2:D" & LastRow).SpecialCells(xlCellTypeConstants, 23) 'we select only NON BLANK cells
i = 2 'initial row
For Each rng In MyRange
Range("H" & i).Value = rng.Offset(0, -1).Value 'value of adjacent cell (Column C)
Range("I" & i).Value = rng.Value 'value of cell in column D
i = i + 1
Next rng
Application.ScreenUpdating = True
End Sub
After executing code I get:
And trying different data works too:
Hope you can adapt this to your needs.

Apologies for the unclear explanation of the problem. I have provided here below a solution I have sorted out. I was looking for a code that could execute vlookup without returning the same values. Below is the solution. I am aware that the code might not be the cleanest and most elegant one but it is effective and run fast enough for large data sample.
Sub Matching()
Dim Search_Array As Variant
Dim Target_MatchValue As Variant
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
'data must be ordered in order to apply the non-repetitive condition
Search_Array = Sheet1.Range("A2", Sheet1.Range("A1").End(xlDown)) 'use this array to loop through the value to search for
n = 0
Sheet1.Activate
With ActiveSheet
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range(Cells(2 + n, 4), Cells(1000, 4)), 0) 'This code will return the value used for the shifting range
Set Target_Range = .Range(Cells(2 + n, 4), Cells(1000, 5)) 'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
'target_range.select Activate this code in order to see the macro in action
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) 'store the vlookup value in an array in order to increase the efficiency the code and to speed up the whole proces
If IsError(arr) Then
.Cells(2 + n, 2).value = "" 'if the macro does not find anything, no value will be recorded anywhere
Else
.Cells(1 + n + Target_MatchValue, 2).value = Search_Array(counter, 2) 'Return the value of the search_array in this cell so to match column A values with column D values if they are found
End If
If IsError(arr) Then
n = n
ElseIf Target_MatchValue = 0 Then 'if the macro does not find anything, the shifting range does not shift so that subsequent values can be searched in the same range without missing precious matches
n = n + 1
ElseIf Target_MatchValue > 0 Then 'if there is a matching value between Column A and Column B, the shifting range shifts by the n + the distance between the the current vlookupvalue and the found value. Note that Data must be stored in a filtered order otherwise vlookup will not work correctly
n = n + Target_MatchValue
End If
Next counter
End With
End Sub
By exchanging ideas with some friends, I was told to think about a potential helper column that would be used to store incremental numbers. This helper column would store incremental numbers that would help to meet the non-repetition condition. Please see the below example.
The idea here is that if a value is found in column E, I store n being equal to the value found in the helper column. Then the code needs to verify if the future values' n are bigger than previous n. If this condition is met, then the one-repetition condition is fulfilled. n changes value to the next bigger value.
For example, if I find L in the right table, I report 96 as value and store N being equal to 11. When I search for the next value of L, the new n must be bigger than the current n otherwise I will not store the new found value. The value 77 found has indeed a bigger n than the previous value as 12 is bigger than 11. I hope this helps.

Related

Unique Id Generator and Randomizer

I am trying a few items for a Secret Santa spreadsheet.
A Unique ID generator to print the UID in Column B for a list of names in Column A.
A randomizer to print the ID numbers in a random order in Column C with the restraint that Column B UID cannot equal Column C UID, ensuring no one gets themselves.
List Name for the random UID in Column C in Column D.
The UIDs are to start at 1 and then count until the last name receives an ID. I also want the generator to handle creating an ID for a name that is added anywhere in the list (beginning, middle, end).
I found some answers here and on other websites.
Some use complicated looping others the GUID function that I do not understand.
In general, the answers are for existing lists and not a new list with no UIDs.
I assume I would:
Create the UIDs and print them to Column B.
Save Column A and B into an array.
Randomize and Print the UID's into Column C.
Use the array to get the name for the randomized UID's in Column C and print the corresponding name in Column D.
I am unsure if this methodology is a "good" approach for this type of problem, but I would be interested in hearing other methodologies.
The only code I have so far is the row counter.
Sub secret_santa()
Dim person_count As Integer
Dim uid As Integer
'Count Number of Used Rows
person_count = ActiveSheet.UsedRange.Rows.Count
'Subtract Header from person_count
person_count = person_count - 1
End Sub
If I'm reading correctly, you basically just want to shuffle the array whilst also imposing the constraint that no user ID cannot end up corresponding to itself.
There are a number of ways you can implement this. The approach below is not very generalised, can be refactored (to use more functions/subroutines) and a bit clunky. Nonetheless, it might be okay and may give you some ideas regarding implementation:
Option Explicit
Private Function GetArrayOfNames(ByVal someRange As Range) As Variant
' someRange should be a single-column, vertical range.
Debug.Assert someRange.Columns.Count = 1
Debug.Assert someRange.Areas.Count = 1
Debug.Assert someRange.Rows.Count > 1
GetArrayOfNames = someRange.Value
End Function
Private Sub SecretSantaShuffle()
' This procedure will overwrite the contents of the initial range,
' and the three columns to its right.
Dim rangeContainingNames As Range
Set rangeContainingNames = ThisWorkbook.Worksheets("Sheet1").Range("A2:A7")
Dim inputArray() As Variant
inputArray = GetArrayOfNames(rangeContainingNames)
Dim rowCount As Long
rowCount = UBound(inputArray, 1)
ReDim Preserve inputArray(1 To rowCount, 1 To 4)
Const NAME_COLUMN_INDEX As Long = 1
Const UID_COLUMN_INDEX As Long = 2
Const RANDOM_NAME_COLUMN_INDEX As Long = 3
Const RANDOM_UID_COLUMN_INDEX As Long = 4
Do
Dim userIdPool As Collection
Set userIdPool = New Collection
Dim rowIndex As Long
For rowIndex = LBound(inputArray, 1) To UBound(inputArray, 1)
inputArray(rowIndex, UID_COLUMN_INDEX) = rowIndex
userIdPool.Add rowIndex, Key:=CStr(rowIndex)
Next rowIndex
For rowIndex = LBound(inputArray, 1) To UBound(inputArray, 1)
Dim randomRowIndex As Long
Do While True
randomRowIndex = userIdPool.Item(Application.RandBetween(1, userIdPool.Count))
If randomRowIndex <> rowIndex Then Exit Do
If userIdPool.Count = 1 Then Exit Do
DoEvents
Loop
userIdPool.Remove CStr(randomRowIndex)
inputArray(rowIndex, RANDOM_NAME_COLUMN_INDEX) = inputArray(randomRowIndex, NAME_COLUMN_INDEX)
inputArray(rowIndex, RANDOM_UID_COLUMN_INDEX) = inputArray(randomRowIndex, UID_COLUMN_INDEX)
Next rowIndex
Loop While userIdPool.Count > 0
rangeContainingNames.Resize(UBound(inputArray, 1), UBound(inputArray, 2)).Value = inputArray
End Sub
You will likely need to change what gets assigned to rangeContainingNames. My list of names was in range A2:A7 of worksheet Sheet1 but you should change the sheet name and range address to reflect the location of your names.

Create dynamically sized array to store row counter

The function below finds the first result.
There could be duplicate rows with matching values that meet my if statements. How would I create an array to store the row numbers the search function found so that I can process the data later.
How would I create the array size based on the number of results found in the for loop?
I am assuming that the for loop counter will have some sort of role to play in this. Let's say the for loop found 2 matches in row numbers 56 and 98 matching my if statements:
array_example(counter, 0) = 56
array_example(counter, 0) = 98
The stored values would be:
array_example(1, 0) = 56
array_example(2, 0) = 98
Private Sub Complex_Search(col1, cval1, col2, cval2)
'MsgBox (col1 & " " & col2)
'MsgBox (cval1 & " " & cval2)
Dim i
Dim lRow
Dim Counter
lRow = Cells(Rows.Count, 1).End(xlUp).row
Counter = 0
With Sheets("Office Spaces")
For i = 2 To lRow
If LCase(.Cells(i, col1).Value) = LCase(cval1) And LCase(.Cells(i, col2).Value) = LCase(cval2) Then
row = i
Counter = Counter + 1
End If
Next i
End With
If row = "" Then
MsgBox ("Search complete. 0 results found")
Else
GetRowData (row)
UserForm1.resmax.Value = 1
End If
End Sub
It's worth noting that you haven't even initialized row, and have just let vba implicitly declare it as a variant type for you. To avoid common problems that arise from typos, include Option Explicit at the top of your code and Dim every variable with the type beside it. For example: Dim i as long. Dim i will work, but it will declare it as a variant type
To initialize an array in VBA you use Dim row() as variant. From there you can re-dimension its size using Redim row(LboundX to UboundX) but this will reset all the stored values to zero. To get around this use Redim Preserve row(LBoundX to UBound X).
If you wish to use a 2D array, add a comma and then put the bounds for the next dimension Redim Preserve row(LBoundX to UBound X, LboundY to UBoundY)
At the top of your code I would include
Dim row() as Variant
Redim Preserve row(1 to 1)
Then within the loop I would change row = i to
row(Ubound(row)) = i
Redim Preserve row(1 to Ubound(row) +1)
Now that you have an array though, the check you do below will no longer work and will likely throw an error because you there's no specified index. Instead I suggest changing it from If row = "" Then to If Counter = 0 Then.
I'm not sure what the intention is with GetRowData(row) but you can just access each row number via row(i). It is worth noting however, that the row array will have Counter +1 number of items, but the last one will be blank. You could get around this by adding in an if statement within the already existing one that would look something like this:
If Counter = 0 Then
row(1) = i
Else
ReDim Preserve row(1 To UBound(row) + 1)
row(UBound(row)) = i
End If
Counter = Counter + 1
By implementing this change, row should have exactly Counter number of items that all have a non-empty value
I don't really suggest making a column array because it becomes more cumbersome to change the array size. Redim preserve or not only allows you to change the last dimension in the array, so to change the number of rows you would have to set the array equal to the transpose of itself, do the redim and then set it to the transpose of itself again. It's just needlessly messy. If you're pasting it to a sheet and need it to be in a column you could just transpose it at the end instead.

VBA Insert value to array replacing value instead of inserting

I have a column of data with unique strings where the first 4 characters in the string may be a repeat of the first 4 characters in another string, in a format similar to:
ABCDEF
ABCDXY
ABCDKL
DTYTZF
DTYTSD
I am attempting to loop through this data to identify which 4 starting characters appear more then three times. If the first 4 digits of the string occur 3 times or more, I would like to remove these from the array entirely, and end up with an array that excludes these values. For example, in my column above, as 3 strings or more begin with 'ABCD', I would like to remove all strings that begin with this code, and have only every other value remain, such that my result would be:
DTYTZF
DTYTSD
I am currently looping through the array, pushing any value that occurs three times or more into a NEW array, and plan to then use that list to do a second pass on the original array, and remove any matches. This may not be the most efficient way, but I've not been able to determine a better way that is guaranteed not to mess my data up.
I have worked through looping through the strings to identify which strings occur more then once, but when I try to push them to an array, the string successfully is pushed to the array, but is then replaced with the next value as soon as it is pushed to the array. I know the value is pushed correctly, because if I view the array immediately afterwards, I see the value in the array. When the next value is pushed and you view the array again, only the new value is displayed (The older ones are not).
I believe this is due to my limited understanding of ReDim-ing arrays, and me not fully understanding a code snippet for pushing this value into an array. My (condensed) code is as follows:
Sub pickupValues()
Dim valuesArray()
Dim i As Long
Dim y As Long
Dim sizeCheck As Long
Dim tempArray() As String
valuesArray() = Worksheets("Sheet1").Range("A1:A10").Value
For i = LBound(valuesArray) To UBound(valuesArray)
sizeCheck = 0
For y = LBound(valuesArray) To UBound(valuesArray)
If Left(valuesArray(i, 1), 4) = Left(valuesArray(y, 1), 4) Then
sizeCheck = sizeCheck + 1
i = y
If sizeCheck >= 3 Then
ReDim tempArray(1 To 1) As String 'I'm not sure why I need to do this.
tempArray(UBound(tempArray)) = Left(valuesArray(i, 1), 4) 'I believe this is what pushes the value into the array.
ReDim Preserve tempArray(1 To UBound(tempArray) + 1) As String 'Again unsure on what the purpose of this is.
viewArray (tempArray)
End If
End If
Next y
Next i
End Sub
Function viewArray(myArray)
Dim txt As String
Dim i As Long
For i = LBound(myArray) To UBound(myArray)
txt = txt + myArray(i) + vbCrLf
Next i
MsgBox txt
End Function
What am I doing wrong?
I would like to re-use the same basic code later in the function to push other values OUT of an array based on if they match the string or not, but it seems VBA does not like to move values out of arrays either. Is there an easy solution that would match both scenarios?
I've rewritten what you are trying to do. I'm using the filter function to quickly get your results in the array
Option Explicit
Public Sub pickupValues()
Dim tmp As Variant
Dim results As Variant
Dim i As Long
Dim v
' Make sure this matches your range
With ThisWorkbook.Sheets("Sheet1")
' Important to transpose the input here as Filter will only take a 1D array. Even though it's only 1 column, setting an array this way will generate a 2D array
tmp = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)).Value2)
End With
' ReDiming to the maximum value and slimming down afterwards is much quicker then increasing your array each time you've found a new value
ReDim results(1 To UBound(tmp))
For Each v In tmp
' Less then 2 as first result is '0'. Will return '-1' if can't be found but as test criteria is in the array it will always be at least 0
If UBound(Filter(tmp, Left(v, 4))) < 2 Then
i = i + 1
results(i) = v
End If
Next v
' Redim Preserve down to actual array size
If i > 0 Then
ReDim Preserve results(1 To i)
viewArray (results)
Else
MsgBox "Nothing Found"
End If
End Sub
' Should really be a sub as doesn't return anything back to caller
Public Sub viewArray(myArray)
MsgBox Join(myArray, vbCrLf)
End Sub
Your algorithm is not helping you.
Option 1:
Sort your array. Then you can make a single pass to find sequential values with the same first four characters and count them.
Option 2:
Use a Dictionary object: first four characters as key, number of occurrences as value.

Check if any value in array is greater than zero (efficiently) in Excel using vba

I am attempting to check if any value in a dynamic array of size "i" by one is greater than zero where "i" is a user input. If false, the value of the first element in the array would show in the next column. If true, the values of the array update by essentially moving down one element. I believe I have found answers for this question in java here, but haven't had any luck finding it in vba. I believe this could be done with a for loop as done here, but would like something more efficient if it exists. Since I do not know any syntax which may work the code hangs at "If any x > 0 Then"
Dim i, z, u As Integer
Dim fir As Integer
Dim las As Integer
Dim n As Long
Dim x As Variant
'SET VALUE OF ROWS FOR ARRAY
i = Worksheets("INPUTS").Range("C6").Value
Set s = Worksheets("DATA")
'FIND LAST VALUE IN DATA
n = s.Cells(s.Rows.Count, "A").End(xlUp).Row
'BEGIN LOOP THROUGH DATA SET
For z = 1 To n
'SET/RESET RANGE TO CHECK FOR CONSECUTIVE VALUES LESS THAN ZERO
fir = z
las = i + z - 1
x = (s.Range("C" & fir, "C" & las).Value)
u = s.Range("C" & UBound(x)).Value
If any x > 0 Then
Else: s.Cells(4, z) = x(1, 1).Value
End If
Next z
I'm a beginner and new to the forum so feel free to tear me a new one on anything against best practices relating to the code or the question, thank you.
use worksheet function
If Application.WorksheetFunction.Max(Range("a1:a100")) > 0 Then
MsgBox "value higher than zero"
end if
In order to speed up the processing you may consider converting Excel Range (for example A1:A100) into array Arr and then iterating through array:
Dim Arr() As Variant
Arr = Range("A1:A100")
Also, you may consider setting property Application.ScreenUpdating = False prior to starting the iterations (in case you change the cells' values during iteration as per your example) and resetting it to True afterwards.
Hope this may help.

Return label and value based on order in Excel

Suppose I have a two column array in excel where the first column is text and the second column is numbers. I would like to have a command that would return an array sorted according to the values in the second column. I don't want to use the custom sort command because I would like to be able to update the numerical values in the second column and automatically have the sorted array updated.
The only other way of sorting automatically is by programming... MACROs.
You can either create a button and assign the macro to that button
OR
You put it in a selection change event which runs your macro every time a cell has changed.
up to you.
In the following code I did it for a button:
Sub btnSort()
Dim swapped As Boolean ' Boolean value to check if the values have been swapped
Dim boolEmpty As Boolean ' Boolean value to check if the cell value is empty
Dim tmp1, tmp2 As Variant ' Temporary variable,which holds temporary value
Dim numRows As Integer ' Number of NON-EMPTY rows
Dim tempArray1 As Variant ' Holds values in column 1 with certain values
Dim tempArray2 As Variant ' Holds values in column 2 with numerica values
boolEmpty = False 'Give initial value to variable; Assuming that the first checked cell is NOT EMPTY
'Count the number of cells with actual values in them
numRows = 0
ctr = 1
Do While (boolEmpty <> True)
'If the cell value contains something then increment variable numRows
If Sheet6.Cells(ctr, 1).Value > 0 Then
numRows = numRows + 1
boolEmpty = False
ctr = ctr + 1
Else
'if true then exit while loop
boolEmpty = True
End If
Loop
ReDim tempArray1(numRows) ' Re-dimensionalize the array with the appropriate size
ReDim tempArray2(numRows) ' Re-dimensionalize the array with the appropriate size
'Fill tempArray1 & 2 with values
For i = 0 To numRows - 1
tempArray1(i) = Sheet6.Cells(i + 1, 1).Value
tempArray2(i) = Sheet6.Cells(i + 1, 2).Value
Next i
'Set variables
swapped = True
ctr = 0
'If swapped remains TRUE then continue sorting the array
Do While (swapped)
swapped = False
ctr = ctr + 1
'BUBBLE SORT
'Check if next element in array is bigger than the first one.
'If TRUE then swap the elements
'If FALSE then continue until looking through teh array until done.
For i = 0 To numRows - ctr
If tempArray2(i) > tempArray2(i + 1) Then
tmp1 = tempArray1(i)
tmp2 = tempArray2(i)
tempArray1(i) = tempArray1(i + 1)
tempArray2(i) = tempArray2(i + 1)
tempArray1(i + 1) = tmp1
tempArray2(i + 1) = tmp2
swapped = True
End If
Next i
Loop
'Redisplay the sorted array in excel sheet
For i = 0 To UBound(tempArray2)
Sheet6.Cells(i + 1, 1).Value = tempArray1(i)
Sheet6.Cells(i + 1, 2).Value = tempArray2(i)
Next i
End Sub
The reason I did it for a button is because if you do it the selection change event way your excel is constantly going to refresh every time you change a cell. BUT, there is a work around for this.
In the example above I used bubble sort, you can find many examples on how to understand it online somewhere.
if you want my code to work you will have to change my sheet6.cells(....
to
your sheet number, depending where your list is found in your workbook.
In the "Count the number of cells with actual values..."
You will have to change ...Cells(ctr,1) to the row and column index where your list is found.
Hope I didn't confuse you.
Here is the other way I was talking about earlier:
'If value has changed in column 2 then run macro
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 1 And Target.Column < 3 Then
MsgBox Target.Column
End If
End Sub
This code needs to be in the same sheet. It checks to see if the value that you changed is in fact within column 2 ( Target.Column > 1 And Target.Column < 3 ) You can go a step further and add Target.row < 10 (which means, the cell that was modified is column 2 and less than row 10)
where you see msgbox is where you will copy and paste the code "bubble sort and etc.." in.
Hope this helps.

Resources