Related
I have a code that converts a column from vertical state to horizontal (each group to be in one row)
Here's some dummy data
Groups Amount Notes Name
A 10 N1 GroupA
A 20 N2 GroupA
A 30 N3 GroupA
B 40 N4 GroupB
B 50 N5 GroupB
B 60 N6 GroupB
B 70 N7 GroupB
C 80 N8 GroupC
D 90 N9 GroupD
D 100 N10 GroupD
Here's the code that deals with the second column only
Sub Test()
Dim v, a, i As Long
v = Cells(1).CurrentRegion
ReDim b(UBound(v) + 1)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(v)
a = .Item(v(i, 1))
If IsEmpty(a) Then a = b
a(0) = v(i, 1)
a(UBound(a)) = a(UBound(a)) + 1
a(a(UBound(a))) = v(i, 2)
.Item(v(i, 1)) = a
Next i
Range("G2").Resize(.Count, UBound(a) - 1) = Application.Index(.Items, 0)
End With
End Sub
The code works fine for the second column, but I need to deal with the third column too with the same idea. And as for the fourth column will be just once (in the output would be in one column)
Here's the expected output
The solution to your problem is a little more complicated than it first seems. But kudos to you for using a Dictionary rather than trying to do everything via arrays.
The code below uses a Dictionary whose keys are the values in the Groups column. The Item associated with these keys is an Arraylist. In turn, the Arraylist is populated with Arraylists comprising the Amount,Note and Nname values for each row corresponding to the Key in the Group Column. The Arraylist is used because we can easily delete items from An Arraylist.
Note that the Item method of Scripting.Dictionaries and ArrayLists is the default method, and for this reason I don't explicity invoke the Item method in the code. If the default method were something other than Item, then I would have specifically stated the default method.
The code below is a good deal longer than in your original post, but I will hope you will see how things have been split up into logical tasks.
You will also see that I use vertical spacing a lot to break codee withing methods into 'paragraphs'. This is a personal preference.
Public Sub Test2()
Dim myD As Scripting.Dictionary
Set myD = GetCurrentRegionAsDictionary(Cells(1).CurrentRegion)
Dim myArray As Variant
myArray = GetPopulatedOutputArray(myD)
Dim Destination As Range
Set Destination = Range("A20")
Destination.Resize(UBound(myArray, 1), UBound(myArray, 2)).Value = myArray
End Sub
'#Description("Returns an Array in the desired output format from the contents of the Scripting.Dictionary created from the CurrentRegion")
Public Function GetPopulatedOutputArray(ByRef ipD As Scripting.Dictionary) As Variant
Dim myAmountSpan As Long
myAmountSpan = MaxSubArrayListSize(ipD)
Dim myArray As Variant
ReDim myArray(1 To ipD.Count, 1 To 2 + myAmountSpan * 2)
Dim myHeaderText As Variant
myHeaderText = GetHeaderTextArray(ipD, myAmountSpan)
Dim myIndex As Long
For myIndex = 0 To UBound(myHeaderText)
myArray(1, myIndex + 1) = myHeaderText(myIndex)
Next
Dim myRow As Long
myRow = 2
Dim myKey As Variant
For Each myKey In ipD
myArray(myRow, 1) = myKey
Dim myCol As Long
myCol = 2
Dim myList As Variant
For Each myList In ipD(myKey)
myArray(myRow, myCol) = myList(0)
myArray(myRow, myCol + myAmountSpan) = myList(1)
If VBA.IsEmpty(myArray(myRow, UBound(myArray, 2))) Then
myArray(myRow, UBound(myArray, 2)) = myList(2)
End If
myCol = myCol + 1
Next
myRow = myRow + 1
Next
GetPopulatedOutputArray = myArray
End Function
'#Description("Returns an array contining the appropriately formatted header text")
Public Function GetHeaderTextArray(ByRef ipD As Scripting.Dictionary, ByVal ipAmountSpan As Long) As Variant
' The Scripting.Dictionary does not maintain order of addition
' so we need to search for a key longer than one character
Dim myFoundKey As String
Dim myHeaderList As ArrayList
Dim myKey As Variant
For Each myKey In ipD
If Len(myKey) > 2 Then
myFoundKey = myKey
Set myHeaderList = ipD(myKey)(0)
Exit For
End If
Next
Dim myT As String
myT = myFoundKey & ","
Dim myIndex As Long
For myIndex = 1 To ipAmountSpan
myT = myT & myHeaderList(0) & CStr(myIndex) & ","
Next
For myIndex = 1 To ipAmountSpan
myT = myT & myHeaderList(1) & CStr(myIndex) & ","
Next
myT = myT & myHeaderList(2)
' removeove the header text as it is no longer needed
ipD.Remove myFoundKey
GetHeaderTextArray = Split(myT, ",")
End Function
'#Description("Returns a Dictionary of arraylists using column 1 of the current region as the key
Public Function GetCurrentRegionAsDictionary(ByRef ipRange As Excel.Range) As Scripting.Dictionary
Dim myArray As Variant
myArray = ipRange.Value
Dim myD As Scripting.Dictionary
Set myD = New Scripting.Dictionary
Dim myRow As Long
For myRow = LBound(myArray, 1) To UBound(myArray, 1)
Dim myList As ArrayList
Set myList = GetRowAsList(myArray, myRow)
Dim myKey As Variant
Assign myKey, myList(0)
myList.RemoveAt 0
If Not myD.Exists(myKey) Then
myD.Add myKey, New ArrayList
End If
' Add an arraylist to the arraylist specified by Key
myD.Item(myKey).Add myList
Next
Set GetCurrentRegionAsDictionary = myD
End Function
'#Description("Get the size of largest subArrayList")
Public Function MaxSubArrayListSize(ByRef ipD As Scripting.Dictionary) As Long
Dim myMax As Long
myMax = 0
Dim myKey As Variant
For Each myKey In ipD
If ipD(myKey).Count > myMax Then
myMax = ipD(myKey).Count
End If
Next
MaxSubArrayListSize = myMax
End Function
'#Description("Returns a row of an Array as an ArrayList")
Public Function GetRowAsList(ByRef ipArray As Variant, ByVal ipRow As Long) As ArrayList
Dim myList As ArrayList
Set myList = New ArrayList
Dim myIndex As Long
For myIndex = LBound(ipArray, 2) To UBound(ipArray, 2)
myList.Add ipArray(ipRow, myIndex)
Next
Set GetRowAsList = myList
End Function
Public Sub Assign(ByRef ipTo As Variant, ByRef ipFrom As Variant)
If VBA.IsObject(ipFrom) Then
Set ipTo = ipFrom
Else
ipTo = ipFrom
End If
End Sub
I did it a little differently:
Sub ColsToRows()
Dim dict As Dictionary
Dim inner As Dictionary
Dim arr() As Variant
Dim arrNotExpand() As Variant
'add headers of columns you don't want to have expanded to array
arrNotExpand = Array("Name")
Dim myRange As Range
'set start of range you want to be converted; vals in first column will be used for keys in main dict
Set myRange = Range("A1").CurrentRegion
Dim Destination As Range
'set start destination range
Set Destination = Range("G1")
'creating main dict
Set dict = New Dictionary
'looping through all cells in first column (ex header)
For x = 2 To myRange.Rows.Count
'define key
dictKey = Cells(x, 1).Value
'check if key exists
If dict.Exists(dictKey) Then
'if exists, get innerKey, add val from each col to its inner dict
For y = 2 To myRange.Columns.Count
innerKey = Cells(1, y).Value
newVal = Cells(x, y).Value
'getting array from key, adding val to it, and reassigning updated array
arr = dict(dictKey)(innerKey)
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = newVal
dict(dictKey)(innerKey) = arr
Next y
Else
'key does not exist, create new inner dict
Set inner = New Dictionary
'add inner dict for each col, and assign first vals
For y = 2 To myRange.Columns.Count
innerKey = Cells(1, y).Value
newVal = Cells(x, y).Value
arr = Array(newVal)
inner.Add innerKey, arr
Next y
'add inner dict to main dict
dict.Add dictKey, inner
End If
Next x
'establish maxCols, i.e. the max length of any array for inner
maxCols = 1
'since we're retrieving the expanded version of arr for each inner, we can just check the first to get the maxCols val
For Each dictKey In dict.Keys
'checking lengthArray
lengthArray = UBound(dict(dictKey)(dict(dictKey).Keys()(1))) + 1
'if it is larger than prev stored val, use new length
If lengthArray > maxCols Then
maxCols = lengthArray
End If
Next dictKey
'convert dict to Destination
'header for keys main dict
Destination = myRange.Cells(1, 1)
'keep track of offset rows
countRow = 0
For Each dictKey In dict.Keys
'keep trach of offset cols
countCol = 0
For Each innerKey In dict(dictKey)
'if so, add the dictKey
If countCol = 0 Then
Destination.Offset(1 + countRow, 0) = dictKey
End If
'if innerKey not in arrNotExpand, we want use full array
If IsError(Application.Match(innerKey, arrNotExpand, 0)) Then
'if we are looking at the first key, also add the headers for each inner dict key
If countRow = 0 Then
For col = 1 To maxCols
'add increment for headers, e.g. "Amount1", "Amount2" etc. (replace necessary for getting rid of whitespace)
Destination.Offset(countRow, 1 + countCol + col - 1) = Replace(innerKey + Str(col), " ", "")
Next col
End If
'get length of arr for specific inner dict
lengthArray = UBound(dict(dictKey)(innerKey)) + 1
'use here for resizing and fill with array
Destination.Offset(1 + countRow, 1 + countCol).Resize(1, lengthArray) = dict(dictKey)(innerKey)
'adjust offset cols
countCol = countCol + maxCols
Else
'only True if the first innerKey is in arrNotExpand
If countRow = 0 Then
Destination.Offset(countRow, 1 + countCol) = innerKey
End If
'no expansion, so use only first val from array
Destination.Offset(1 + countRow, 1 + countCol) = dict(dictKey)(innerKey)(0)
'adjust offset col just by one
countCol = countCol + 1
End If
Next innerKey
'adjust offset row for next dict key
countRow = countRow + 1
Next dictKey
End Sub
Make sure to enter the correct references for Set myRange = Range("A1").CurrentRegion and Set Destination = Range("F1"). Add the headers for columns that you don't want to expand to this array : arrNotExpand = Array("Name"). As is, you'll get the expected output. Let's say you add "Amount" as well, so: arrNotExpand = Array("Amount", "Name"), then you'll get this:
If you add more columns to the range, this works. Just make sure that all your headers are unique (else you'll run into an error with assigning new dict.keys). Let me know if anything is unclear, or if you find a bug.
I have the follow code to fill cells in excel one by one and it works the way I want it to but it gives me this error when it runs through the array. How do I fix this error? Thanks
The error is "Subscript out of range. Error: 9"
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
Cells(i, 1) = finalSplit(0)
Cells(i, 2) = finalSplit(1)
Cells(i, 3) = finalSplit(2)
Cells(i, 4) = finalSplit(3)
i = i + 1
s = s + 1
Next
I checked if finalSplit contains enough values like Thomas said and it worked.This is the new code below.
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
If UBound(finalSplit) > 1 Then
Cells(i, 1) = finalSplit(0)
Cells(i, 2) = finalSplit(1)
Cells(i, 3) = finalSplit(2)
Cells(i, 4) = finalSplit(3)
i = i + 1
s = s + 1
End If
Next
As other commenters have pointed out, why not add another control variable?
Dim item As Variant
Dim splitString() As String
Dim finalSplit() As String
Dim i As Integer, j As Integer, s As Integer
i = 1
For Each item In splitString
finalSplit = Split(splitString(s), ",")
For j = 0 To UBound(finalSplit)
Cells(i, j + 1) = finalSplit(j)
Next j
i = i + 1
s = s + 1
Next
Be aware that this can loop more than the 4 times you expect. A lazy way to solve this would be to add If j > 3 Then Exit For before Next j
I tested this with the following code (it works!), as I have no idea what splitString() or finalSplit() is in your case:
Sub test()
Dim finalSplit As Variant
Dim j As Integer
finalSplit = Split("1,2,3,4,5", ",")
For j = 0 To UBound(finalSplit)
Cells(1, j + 1) = finalSplit(j)
If j > 3 Then Exit For
Next j
End Sub
Looping Through Elements of Arrays
An array created by the Split function is always 0-based (even if Option Base 1). Similarly, not quite related, an array created by the Array function is dependent on Option Base unless you use its parent VBA e.g. arr = VBA.Array(1,2,3). Then it is always zero-based.
Looping through the elements of an array (1D array) is done in the following two ways:
For Each...Next
Dim Item As Variant
For Each Item In Arr
Debug.Print Item
Next Item
For...Next
Dim i As Long
For i = LBound(Arr) To Ubound(Arr)
Debug.Print Arr(i)
Next i
Since we have established that Split always produces a zero-based array, in the second example we could use 0 instead of LBound(Arr):
`For...Next`
Dim i As Long
For i = 0 To Ubound(Arr)
Debug.Print Arr(i)
Next i
Option Explicit
Sub DoubleSplit()
Const IniString As String = "A,B,C,D/E,F,G,H/I,J,K/L/M,N,O,P,Q,R"
Dim SplitString() As String: SplitString = Split(IniString, "/")
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
ws.Cells.ClearContents ' remove previous data; clears the whole worksheet
Dim FinalSplit() As String
Dim Item As Variant ' SplitString Control Variable
Dim r As Long ' Worksheet Row Counter
Dim f As Long ' FinalSplit Element Counter
' For Each...Next
For Each Item In SplitString
r = r + 1
FinalSplit = Split(Item, ",")
Debug.Print Join(FinalSplit, ",")
For f = 0 To UBound(FinalSplit)
ws.Cells(r, f + 1).Value = FinalSplit(f)
Next f
Next Item
r = r + 1 ' add an empty row
Dim s As Long ' SplitString Element Counter
' For...Next
For s = 0 To UBound(SplitString)
r = r + 1
FinalSplit = Split(SplitString(s), ",")
Debug.Print Join(FinalSplit, ",")
For f = 0 To UBound(FinalSplit)
ws.Cells(r, f + 1).Value = FinalSplit(f)
Next f
Next s
' Results
' A,B,C,D
' E,F,G,H
' I,J,K
' L
' M,N,O,P,Q,R
'
' A,B,C,D
' E,F,G,H
' I,J,K
' L
' M,N,O,P,Q,R
End Sub
I have the following data
0/3, 1/1, 3/4
1/3, 3/2, 6/2
12/1, 3/6, 3/4
3/4, 0/3, 1/1 'will be considered is duplicate with the first data
Is there any way to find and remove duplicate data like this?
My current method is to split into 3 strings based on "," then check with the following condition.
'I got each String value by mid command.
'FrstStr1: First String of String 1
'SecStr1: Second String of String 1
'ThrStr1: Third String of String 1
'FrstStr2: First String of String 2
'SecStr2: Second String of String 2
'ThrStr2: Third String of String 2
if (FrstStr1 = FrstStr2 and SecStr1 = SecStr2 and ThrStr1 = ThrStr2) or
(FrstStr1 = FrstStr2 and SecStr1 = ThrStr2 and ThrStr1 = SecStr2) or
() or () .... then
I listed 6 possible cases and put them into if condition like above.
Make Array by Spliting data with delimiter comma.
And Sorting Array by function.
Ceck duplicated data by Dictionary.
## Code ##
Sub test()
Dim vR(), vDB
Dim dic As Object
Dim v As Variant
Dim s As String
Dim i As Long, n As Long
Set dic = CreateObject("Scripting.Dictionary")
vDB = Range("a1").CurrentRegion
For i = 1 To UBound(vDB, 1)
v = Split(vDB(i, 1), ",")
s = newArray(v)
If dic.exists(s) Then
Else
dic.Add s, s
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = vDB(i, 1)
End If
Next i
If n Then
Range("e1").Resize(n) = WorksheetFunction.Transpose(vR)
End If
End Sub
Function newArray(v As Variant)
Dim temp As String
Dim r As Integer, i As Integer, j As Integer
r = UBound(v)
For i = LBound(v) To r - 1
For j = i + 1 To r
v(i) = Trim(v(i))
v(j) = Trim(v(j))
If v(i) > v(j) Then
temp = v(j)
v(j) = v(i)
v(i) = temp
End If
Next j
Next i
newArray = Join(v, ",")
End Function
Image
expoliting Dictionary and ArrayList objects could lead to a very compact (and maintanable) code:
Sub RemoveDuplicatedDataWithoutCountingOrder()
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim j As Long
Dim key As String
Dim datum As Variant, couple As Variant
For Each datum In Range("A1").CurrentRegion.Value
key = vbNullString
With CreateObject("System.Collections.SortedList")
For Each couple In Split(Replace(datum, " ", vbNullString), ",")
.Add couple, 0
Next
For j = 0 To .Count - 1
key = key & .getkey(j)
Next
If Not dict.exists(key) Then dict.Add key, datum
End With
Next
Range("C1").Resize(dict.Count) = Application.Transpose(dict.items)
End Sub
Is there a way (vba code or excel trick) to manipulate a 2 columnar list so that I get a table with all potential combinations depending on a unique identifier in the first column?
E.g. I have one column with Company Names and another with Country Locations. What I need is every set if combinations of the countries per company (see screenshot attached).
This vba module should solve your problem.
Just copy the code to a new module, declare the input and output columns and the number of the first row of your list.
Note that the code will stop once it hits a line where the "Unique Identifier" Cell is empty.
Also, it requires that your list is sorted with respect to your "Unique Identifier".
If a Unique Identifier only appears once, it will still be written into the output list, but only once and with the outColNation2 staying empty in that row. If this is not desired and it should be left out entirely, just delete the commented if-statement.
Example Image of output
Also note, that a unique identifier can repeat at most 100 times. I assume none of them appears that often as that would create a ridiculously long output list.
Option Compare Text
Sub COMBINATIONS()
Dim i As Long, j As Long, k As Long, l As Long, n As Long
Dim arr(100) As String
Dim UI As String
Dim inColUI As Integer, inColNation As Integer
Dim outColUI As Integer, outColNation1 As Integer, outColNation2 As Integer
Dim FirstRowOfData As Integer
Dim YourWS As Worksheet
inColUI = 1 'Column of the "Unique Identifier"
inColNation = 2 'Column of the "Nations" in your example
outColUI = 4
outColNation1 = 5 'output columns
outColNation2 = 6
FirstRowOfData = 2 'First Row of data
Set YourWS = Application.Worksheets("Sheet1") 'Put in your Worksheet Name here.
i = FirstRowOfData
n = FirstRowOfData
With YourWS
Do Until .Cells(i, inColUI) = ""
j = 0
UI = .Cells(i, inColUI)
Do Until .Cells(i - 1, inColUI) <> .Cells(i, inColUI) And j > 0 Or .Cells(i, inColUI) = ""
arr(j + 1) = .Cells(i, inColNation)
i = i + 1
j = j + 1
Loop
If j = 1 Then '<- remove this if-statement and the following marked lines if single appearing UIs should be omitted entirely
.Cells(n, outColUI) = UI '<---
.Cells(n, outColNation1) = arr(1) '<---
n = n + 1 '<---
Else '<---
For k = 1 To j
For l = 1 To j
If arr(k) <> arr(l) Then
.Cells(n, outColUI) = UI
.Cells(n, outColNation1) = arr(k)
.Cells(n, outColNation2) = arr(l)
n = n + 1
End If
Next l
Next k
End If '<---
Loop
End With
End Sub
Edit: cleaned up the code a little bit
Something like the following shows how to iterate through 2 ranges of cells
Dim Rng1 as Range, Rng2 as Range
Dim SrcCell as Range, OthrCell as Range
Dim FullList as string
Rng1 = Range("A1:A12")
Rng2 = Range("B1:B12")
FullList = ""
For Each SrcCell in Rng1
For Each OthrCell in Rng2
FullList = IIF(FullList="","",FullList & vbCrLf) & SrcCell.Value & OthrCell.Value
Next OthrCell
Next srcCell
The FullList string now contains all the combinations but you may require something else. Only intended to give you a start
You need to add code yourself to filter out duplicates
You can do the following (see code below). As another commentee mentioned, when there is only one record of company vs country, it will not show in the output.
The solutions is based on creating a dictionary, each entry is a company and the value is a comma separated string of countries. After the dictionary is created, the dictionary is looped, and a list of countries is then iterated over a nested loop. If the index of the outer loop is the same as the inner index of the loop then the loop is skipped i.e. that would be a Country 1 vs Country 1 combination. Otherwise is added to the output list.
Columns A,B is input and columns D,E,F is output.
Option Explicit
Public Sub sCombine()
Dim r As Range, dest As Range
Dim d As New Dictionary
Dim key As Variant
Dim countries() As String
Dim i As Integer, j As Integer
On Error GoTo error_next
Set r = Sheet1.Range("A1")
Set dest = Sheet1.Range("D:F")
dest.ClearContents
Set dest = Sheet1.Range("D1")
While r.Value <> ""
If d.Exists(r.Value) Then
d(r.Value) = d(r.Value) & "," & r.Offset(0, 1)
Else
d.Add r.Value, r.Offset(0, 1).Value
End If
Set r = r.Offset(1, 0)
Wend
For Each key In d.Keys
countries = Split(d(key), ",")
For i = LBound(countries) To UBound(countries)
For j = LBound(countries) To UBound(countries)
If i <> j Then
dest.Value = key
dest.Offset(0, 1).Value = countries(i)
dest.Offset(0, 2).Value = countries(j)
Set dest = dest.Offset(1, 0)
End If
Next j
Next i
Next key
Exit Sub
error_next:
MsgBox Err.Description
End Sub
I need to assigned a value on Column B depending on the condition in Column A. I formulate a simple code using IF...ElseIf condition (see code below). I have 1000 conditions and I am thinking if I can use a 2 separate arrays for the value of Column A and get the index of the value in column A to 1st array (Array1 ) and match it to the 2nd array (AssignedArray). Something like, for each value found in Column A check the Array1 if the value is exist and get the index and match the index to AssignedArray. Like for example,
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
CODE
For x = 1 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For Each wrd In Sheets(1).Cells(x, 1)
val = wrd
If UCase(val) = "DL2005" Then
Sheets(1).Cells(x, 3).Value = "Trader"
ElseIf UCase(val) = "EFRUEN" Then
Sheets(1).Cells(x, 3).Value = "Trader"
ElseIf UCase(val) = "DESTDIDIER" Then
Sheets(1).Cells(x, 3).Value = "Operations"
ElseIf UCase(val) = "EOGRADY3" Then
Sheets(1).Cells(x, 3).Value = "Trader"
ElseIf UCase(val) = "EKARLSON1" Then
Sheets(1).Cells(x, 3).Value = "Analyst"
ElseIf UCase(val) = "EOKUTOMI1" Then
Sheets(1).Cells(x, 3).Value = "Operations"
End If
Next wrd
Next x
Is it possible to do that?Or is there any way on how to simplify my code instead of using IF ELSEIF condition.
If you have 1k conditions (as you do), then I imagine neither If nor Select statements are appropriate. Furthermore, creating/maintaining expressions (in your code) that evaluate to two 1k-element arrays may be burdensome.
A maintenance friendly approach might be to keep the items in Array1 on some worksheet, and keep the contents of AssignedArray right next to it. Something like the below. Say the yellow values are items that you would have put into Array1 and green values are items you would have put into AssignedArray (I only have 25 as an example).
Then you wouldn't necessarily need any VBA and could purely use Excel functions like VLOOKUP -- or MATCH and INDEX in conjunction. For example, I put this formula in cell E4, which tries to find the value in D4 among the values in column A and returns the corresponding value from column B:
=INDEX($B$1:$B$25,MATCH(D4,$A$1:$A$25,0))
If you still wanted to use VBA, this code should loop over cells D4:D8 (which is the correct range for my spreadsheet, but probably not for yours), make them uppercase (in memory only, not on the sheet), then write the corresponding values in G4:G8:
Option Explicit
Private Sub FillInAssociatedValuesValue()
Dim inputKeys() As Variant ' <-- AKA Array1
inputKeys = ThisWorkbook.Worksheets("Sheet1").Range("A1:A25").Value2 ' Change to wherever items from Array1 are kept
Dim inputValues() As Variant '<-- AKA AssignedArray
inputValues = ThisWorkbook.Worksheets("Sheet1").Range("B1:B25").Value2 ' Change to wherever items from AssignedArray are kept
If (UBound(inputKeys, 1) - LBound(inputKeys, 1)) <> (UBound(inputValues, 1) - LBound(inputValues, 1)) Then
MsgBox ("The number of keys should be the same as the number of associated values. Code will stop running now.")
Exit Sub
End If
Dim dict As Object 'Shouldn't need to add a reference
Set dict = CreateObject("Scripting.Dictionary")
' One pass to fill the dictionary. If there are duplicates, will only add first instance.
Dim rowIndex As Long
For rowIndex = LBound(inputKeys, 1) To UBound(inputKeys, 1)
If Not dict.Exists(inputKeys(rowIndex, 1)) Then
dict.Add UCase$(inputKeys(rowIndex, 1)), inputValues(rowIndex, 1)
End If
Next rowIndex
Dim Key As String
With ThisWorkbook.Worksheets("Sheet1")
For rowIndex = 4 To 8 ' I needed to loop over range D4:D8
Key = UCase$(.Cells(rowIndex, "D").Value2)
If dict.Exists(Key) Then
.Cells(rowIndex, "G").Value2 = dict.Item(Key)
Else
' Some logic in case input is not found, and cannot be mapped to some associated value
.Cells(rowIndex, "G").Value2 = "VALUE NOT FOUND"
End If
Next rowIndex
End With
End Sub
To keep it simple; use For loops to compare Array1 to each cell in column A and if there is a match, use Offset put the corresponding element from AssignedArray into the cell on the right.
Dim Array1 As Variant, AssignedArray As Variant
Dim x As Long, i As Long
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
For x = 2 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = LBound(Array1) To UBound(Array1)
If Cells(x, 1).Value = Array1(i) Then
Cells(x, 1).Offset(, 1).Value = AssignedArray(i)
End If
Next i
Next x
Try
Sub test()
Dim Ws As Worksheet
Dim Array1, AssignedArray
Dim s As String, i As Integer, r As Long, x As Long
Dim k As Integer
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
Set Ws = Sheets(1)
r = Ws.Cells(Rows.Count, 1).End(xlUp).Row
With Ws
For x = 1 To r
s = UCase(.Cells(x, 1))
For i = LBound(Array1) To UBound(Array1)
If s = Array1(i) Then
k = i
Exit For
End If
Next i
.Cells(x, 3) = AssignedArray(k)
Next x
End With
End Sub
If you have a lot of data, it is better to speed up the results by arranging the results into a single sheet instead of entering them one by one into the cell.
Sub test2()
Dim Ws As Worksheet
Dim Array1, AssignedArray
Dim s As String, i As Integer, r As Long, x As Long
Dim k As Integer
Dim vDB, vR()
Array1 = Array("DL2005", "EFRUEN", "DESTDIDIER", "EOGRADY3", "EKARLSON1", "EOKUTOMI1")
AssignedArray = Array("Trader", "Trader", "Operations", "Trader", "Analyst", "Operations")
Set Ws = Sheets(1)
With Ws
vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
r = UBound(vDB, 1)
ReDim vR(1 To r, 1 To 1)
For x = 1 To r
s = UCase(vDB(x, 1))
For i = LBound(Array1) To UBound(Array1)
If s = Array1(i) Then
k = i
Exit For
End If
Next i
vR(x, 1) = AssignedArray(k)
Next x
.Range("c1").Resize(r) = vR
End With
End Sub