Related
I have a data set in my excel sheet, The data in each cell is a set of numbers separated by ";".
The expected result is in 2nd cell all the four numbers are there in both column (G and H), but not in same order. In the next row, the order is same. So is there any way to check the similarity
I have tried using below code but it only seem to highlight (red) first few characters
If anyone wants to see the file then click here
The code is :
Sub highlight()
Dim xRg1 As Range
Dim xRg2 As Range
Dim xTxt As String
Dim xCell1 As Range
Dim xCell2 As Range
Dim I As Long
Dim J As Integer
Dim xLen As Integer
Dim xDiffs As Boolean
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
lOne:
Set xRg1 = Application.InputBox("Range A:", "Similarity finder", xTxt, , , , , 8)
If xRg1 Is Nothing Then Exit Sub
If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Similarity finder"
GoTo lOne
End If
lTwo:
Set xRg2 = Application.InputBox("Range B:", "Similarity finder", "", , , , , 8)
If xRg2 Is Nothing Then Exit Sub
If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Similarity finder"
GoTo lTwo
End If
If xRg1.CountLarge <> xRg2.CountLarge Then
MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "Similarity finder"
GoTo lTwo
End If
xDiffs = (MsgBox("Click Yes to highlight similarities, click No to highlight differences ", vbYesNo + vbQuestion, "Similarity finder") = vbNo)
Application.ScreenUpdating = False
xRg2.Font.ColorIndex = xlAutomatic
For I = 1 To xRg1.Count
Set xCell1 = xRg1.Cells(I)
Set xCell2 = xRg2.Cells(I)
If xCell1.Value2 = xCell2.Value2 Then
If Not xDiffs Then xCell2.Font.Color = vbRed
Else
xLen = Len(xCell1.Value2)
For J = 1 To xLen
If Not xCell1.Characters(J, 1).Text = xCell2.Characters(J, 1).Text Then Exit For
Next J
If Not xDiffs Then
If J <= Len(xCell2.Value2) And J > 1 Then
xCell2.Characters(1, J - 1).Font.Color = vbRed
End If
Else
If J <= Len(xCell2.Value2) Then
xCell2.Characters(J, Len(xCell2.Value2) - J + 1).Font.Color = vbRed
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
One way to do this is to use the first column to create a regular expression and apply it against the second column.
One advantage of using regex is that one of the data returned is the start and length of the match -- perfect for addressing the characters property of the range object.
I used early binding (see the reference to be set in the code notes), but you could use late binding if you must.
I also have the data in columns A & B, but you can alter that with the part of the code that defines the data location.
You should NOT need to use any On Error code. Much better to write the code to handle any forseeable errors. I did NOT do any error checking, and that may need to be added.
If speed is an issue, there are various other modifications which can be made.
The constructed regular expression will have the general appearance of
\b(?:nnn|nnn|nnn|nnn)\b
which means to
match a word boundary
match any of the pipe delimited substrings
match another word boundary.
For more information, see How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops
Option Explicit
'Set reference to Microsoft VBScript Regular Expressions 5.5
Sub highLight()
Dim R As Range, C As Range, WS As Worksheet
Dim RE As RegExp, MC As MatchCollection, M As Match
Dim sSplit As String
'set the data range
' one column wide
' column 2 will be offset 1 to the left
'Obviously you can change this in many ways
'And also work in your user selected method as in your code.
'only requirement is that the ranges be single column, and you can
'easily check for that
Set WS = ThisWorkbook.Worksheets("Sheet4")
With WS
Set R = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
Set RE = New RegExp
Application.ScreenUpdating = False
With RE
.Global = True
'loop through the first column
For Each C In R.Rows
'replace the semicolon with the pipe
sSplit = Replace(Join(Split(C.Value, ";"), "|"), " ", "")
'since data has a terminal semi-colon, need to remove it if present
If Right(sSplit, 1) = "|" Then sSplit = Left(sSplit, Len(sSplit) - 1)
'finish construction of the regex pattern
.Pattern = "\b(?:" & sSplit & ")\b"
'check for matches and change relevant characters font color
Set MC = .Execute(C.Offset(columnoffset:=1))
With C.Offset(-0, 1)
.Font.Color = vbBlack
For Each M In MC
.Characters(M.FirstIndex + 1, M.Length).Font.Color = vbRed
Next M
End With
Next C
End With
End Sub
The heart of your question is how to test for your notion of similarity.
Here is a function which, when given a string consisting of semicolon-delimited items, returns True if the items are the same, though possibly in a different order, and False otherwise. The key idea is to split on ";", sort the resulting array, then rejoin. This will put the strings in a standard sorted order, which can then be directly compared for equality:
Function Sort(A As Variant) As Variant
Dim sorted As Variant, item As Variant
Dim lb As Long, ub As Long
Dim i As Long
Dim items As Object
Set items = CreateObject("System.Collections.ArrayList")
lb = LBound(A)
ub = UBound(A)
ReDim sorted(lb To ub)
For i = lb To ub
item = A(i) 'Somewhat oddly, seems needed
items.Add item
Next i
items.Sort
For i = lb To ub
sorted(i) = items(i - lb)
Next i
Sort = sorted
End Function
Function Similar(s1 As String, s2 As String) As Boolean
Similar = (Join(Sort(Split(s1, ";")), ";") = Join(Sort(Split(s2, ";")), ";"))
End Function
For example, Similar("12;34;56","34;56;12") will evaluate to True but Similar("12;34;56","34;16;12") will evaluate to False.
In your case you have trailing semicolons so they are not being used as delimiters in a standard way. It turns out not to matter: Similar("12;34;56;","34;56;12;") still works as expected.
Similarities
There is a problem with your data: the values in column A end with an "; ", while the values in column B end with ";". The solution presented is to use only the string before the last semi-colon ; with the Split function.
To avoid complications, I integrated the code into your rather cool solution.
The Code
Option Explicit
Sub highlightOrig()
Dim xRg1 As Range
Dim xRg2 As Range
Dim xTxt As String
Dim xCell1 As Range
Dim xCell2 As Range
Dim I As Long
Dim J As Integer
Dim xLen As Integer
Dim xDiffs As Boolean
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
lOne:
Set xRg1 = Application.InputBox("Range A:", "Similarity finder", xTxt, , , , , 8)
If xRg1 Is Nothing Then Exit Sub
If xRg1.Columns.Count > 1 Or xRg1.Areas.Count > 1 Then
MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Similarity finder"
GoTo lOne
End If
lTwo:
Set xRg2 = Application.InputBox("Range B:", "Similarity finder", "", , , , , 8)
If xRg2 Is Nothing Then Exit Sub
If xRg2.Columns.Count > 1 Or xRg2.Areas.Count > 1 Then
MsgBox "Multiple ranges or columns have been selected ", vbInformation, "Similarity finder"
GoTo lTwo
End If
If xRg1.CountLarge <> xRg2.CountLarge Then
MsgBox "Two selected ranges must have the same numbers of cells ", vbInformation, "Similarity finder"
GoTo lTwo
End If
xDiffs = (MsgBox("Click Yes to highlight similarities, click No to highlight differences ", vbYesNo + vbQuestion, "Similarity finder") = vbNo)
Application.ScreenUpdating = False
xRg1.Font.ColorIndex = xlAutomatic
xRg2.Font.ColorIndex = xlAutomatic
Const Delimiter As String = "; "
Dim dLen As Long: dLen = Len(Delimiter)
Dim s() As String
Dim d() As String
Dim cString As String
Dim n As Long
Dim cStart As Long
If Not xDiffs Then
For I = 1 To xRg1.Count
cStart = 1
Set xCell1 = xRg1.Cells(I)
Set xCell2 = xRg2.Cells(I)
cString = Left(xCell1.Value, InStrRev(xCell1.Value, ";") - 1)
s = Split(cString, Delimiter)
cString = Left(xCell2.Value, InStrRev(xCell2.Value, ";") - 1)
d = Split(cString, Delimiter)
For n = 0 To UBound(d)
If IsNumeric(Application.Match(d(n), s, 0)) Then
xCell2.Characters(cStart, Len(d(n))).Font.Color = vbRed
End If
cStart = cStart + Len(d(n)) + dLen
Next n
Next I
Else
For I = 1 To xRg1.Count
cStart = 1
Set xCell1 = xRg1.Cells(I)
Set xCell2 = xRg2.Cells(I)
cString = Left(xCell1.Value, InStrRev(xCell1.Value, ";") - 1)
s = Split(cString, Delimiter)
cString = Left(xCell2.Value, InStrRev(xCell2.Value, ";") - 1)
d = Split(cString, Delimiter)
For n = 0 To UBound(d)
If IsError(Application.Match(d(n), s, 0)) Then
xCell2.Characters(cStart, Len(d(n))).Font.Color = vbRed
End If
cStart = cStart + Len(d(n)) + dLen
Next n
Next I
End If
Application.ScreenUpdating = True
End Sub
How do I count the total number of "alt" and "first" that appeared in a cell and do the same for other cells as well while ignoring empty cells in the process? For instance, if a cell has first, first, alt, first, first, first, it should give me firstcounter = 5 (where firstcounter is the total count for first) and altcounter= 1(altcounter is the total count for alt). After that I can use the value of firstcounter and altcounter found to concatenate them into a string as shown in column B in the form of "first-" & firstcounter, "alt-"& altcounter.
Dim ia As Long
Dim lastrow2 As Long
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
lastrow2 = ws1.Range("A" & ws1.Rows.count).End(xlUp).Row
For ia = 2 To lastrow2
Dim arr() As Variant
' Split the string to an array
arr = Split(ws1.Cells(ia, "A"), ",").Value
'what should i do after split
Enter the following into a code module...
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
Then in cell B2 enter this formula:
=CountWords(A2)
Now copy it downwards as far as you need.
Update
To use the above function from VBA without entering formulas in the worksheet you can do it like this...
Sub Cena()
Dim i&, v
With [a2:a8]
v = .Value2
For i = 1 To UBound(v)
v(i, 1) = CountWords(v(i, 1))
Next
.Offset(, 1) = v
End With
End Sub
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
Update #2
In response to your questions in the comments, you can use this variation instead...
Sub Cena()
Dim i&, v
With [a2].Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
v = .Value2
For i = 1 To UBound(v)
v(i, 1) = CountWords(v(i, 1))
Next
.Cells = v
End With
End Sub
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
In order to make this independent from the words alt and first and whitespaces in the string I would use the following functions
Option Explicit
'Add a reference to Microsoft VBScript Regular Expressions 5.5
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
'Add a reference to Microsoft Scripting Runtime
Function CountWordsA(rg As Range) As String
On Error GoTo EH
Dim dict As Dictionary
Set dict = New Dictionary
Dim vDat As Variant
vDat = RemoveWhiteSpace(rg.Value)
vDat = Split(vDat, ",")
Dim i As Long
For i = LBound(vDat) To UBound(vDat)
If dict.Exists(vDat(i)) Then
dict(vDat(i)) = dict(vDat(i)) + 1
Else
dict.Add vDat(i), 1
End If
Next i
Dim vKey As Variant
ReDim vDat(1 To dict.Count)
i = 1
For Each vKey In dict.Keys
vDat(i) = vKey & "-" & dict(vKey)
i = i + 1
Next vKey
CountWordsA = Join(vDat, ",")
Exit Function
EH:
CountWordsA = ""
End Function
Sub TestIt()
Dim rg As Range
Set rg = Range("A2:A8")
Dim sngCell As Range
For Each sngCell In rg
sngCell.Offset(, 1) = CountWordsA(sngCell)
Next sngCell
End Sub
More about dictionaries and regular expressions
Alternative using Filter() function
This demonstrates the use of the Filter() function to count words via function UBound():
Function CountTerms() (usable also in formulae)
Function CountTerms(ByVal WordList As String, Optional TermList As String = "first,alt", Optional DELIM As String = ",") As String
'Purpose: count found terms in wordlist and return result as list
'[1] assign lists to arrays
Dim words, terms
words = Split(WordList, DELIM): terms = Split(TermList, DELIM)
'[2] count filtered search terms
Dim i As Long
For i = 0 To UBound(terms)
terms(i) = terms(i) & "-" & UBound(Filter(words, terms(i), True, vbTextCompare)) + 1
Next i
'[3] return terms as joined list, e.g. "first-5,alt-1"
CountTerms = Join(terms, ",")
End Function
Example call (due to comment) & help function getRange()
In order to loop over the entire range and replace the original data with the results list:
Sub ExampleCall()
'[1] get range data assigning them to variant temporary array
Dim rng As Range, tmp
Set rng = getRange(Sheet1, tmp) ' << change to sheet's Code(Name)
'[2] loop through array values and get counts
Dim i As Long
For i = 1 To UBound(tmp)
tmp(i, 1) = CountTerms(tmp(i, 1))
Next i
'[3] write to target (here: overwriting due to comment)
rng.Offset(ColumnOffset:=0) = tmp
End Sub
Function getRange(mySheet As Worksheet, tmp) As Range
'Purpose: assign current column A:A data to referenced tmp array
With mySheet
Set getRange = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
tmp = getRange ' assign range data to referenced tmp array
End With
End Function
The current performance of this function is to slow, currently I am working with a list of 500+ item codes on sheet1. The function searches in a range of 200 000 + items on sheet2 to find all matches including partial matches. This means that we include a wildcards before and after the lookup criteria to find all matches.
Currently it takes over 15 mins to complete. Is there a better method to do this? To get this under 5 mins?
Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, _
Optional ByVal stringsRange As Range, Optional Delimiter As String) As String
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim i As Long, j As Long, criteriaMet As Boolean
Set compareRange = Application.Intersect(compareRange, _
compareRange.Parent.UsedRange)
If compareRange Is Nothing Then Exit Function
If stringsRange Is Nothing Then Set stringsRange = compareRange
Set stringsRange = compareRange.Offset(stringsRange.Row - _
compareRange.Row, stringsRange.Column - compareRange.Column)
For i = 1 To compareRange.Rows.Count
For j = 1 To compareRange.Columns.Count
If (Application.CountIf(compareRange.Cells(i, j), _
xCriteria)= 1) Then
ConcatIf = ConcatIf & Delimiter & _
CStr(stringsRange.Cells(i, j))
End If
Next j
Next i
ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Function
Example:
+500 ITEM CODES
Sheet1:
BCD
CDF
XLMH
XPT
ZPY
200 000 + FULL ITEM CODES
Sheet2:
FDBCDGH
HSGDBCDSU
GFD-CDFGDTR
SBGCDFHUD
GKJYCDFFDS
DDFGFDXLMHGFD
SDGXLMHSDFS
SDGVSDXLMHFAMN
DDDSXPTDFGFD
JUYXPTFADS
DDDFFZPYDGDFDF
Outcome should be:
Sheet1:
COLUMN A - COLUMN B
BCD - FDBCDGH,HSGDBCDSU
CDF - GFD-CDFGDTR,SBGCDFHUD,GKJYCDFFDS
XLMH - DDFGFDXLMHGFD,SDGXLMHSDFS,SDGVSDXLMHFAMN
XPT - DDDSXPTDFGFD,JUYXPTFADS
ZPY - DDDFFZPYDGDFDF
To use the following code you will need to add a reference to Microsoft Scripting Runtime. This uses two arrays and compiles the data in a dictionary. This can then be written back to your sheet. The code currently writes the results back to the immediate window which can be displayed using Ctrl+G or View->Immediate Window
Public Sub demo()
Dim compArr As Variant, strArr As Variant
Dim strDict As Dictionary
Dim i As Long
Dim Delimiter As String: Delimiter = "; "
Dim key
' Set data to arrays. This assumes your data is in column A
With Sheets("Sheet1")
' Application.Transpose is a trick to convert the range to a 1D array (otherwise a 2D array will be created)
compArr = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)))
End With
With Sheets("Sheet2")
strArr = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)))
End With
' Initiate dictionary
Set strDict = New Dictionary
' Loop through all the values you wish to find
For i = LBound(compArr) To UBound(compArr)
' Tests if value exists
If Not strDict.Exists(compArr(i)) Then
' Adds value to dictionary and uses filter on string array to get similar matches.
' Join is used to convert the resulting array into a string
strDict.Add key:=compArr(i), Item:=Join(Filter(strArr, compArr(i), True), Delimiter)
End If
Next i
' Read back results
For Each key In strDict.Keys
Debug.Print key, strDict(key)
Next key
End Sub
To maintain all of your current functionality and useability regarding the size of your dataset, this should work for you and be faster than the original code. When I timed it, I used 400,000 full item codes and applied the concatif formula on sheet 1 for 1000 partial matches and it completed all cell calculations in under 9 minutes.
Public Function CONCATIF(ByVal arg_rCompare As Range, _
ByVal arg_vCriteria As Variant, _
Optional ByVal arg_rStrings As Range, _
Optional ByVal arg_sDelimiter As String = vbNullString _
) As Variant
Dim aData As Variant
Dim aStrings As Variant
Dim aCriteria As Variant
Dim vString As Variant
Dim vCriteria As Variant
Dim aResults() As String
Dim ixResult As Long
Dim i As Long, j As Long
If arg_rStrings Is Nothing Then Set arg_rStrings = arg_rCompare
If arg_rStrings.Rows.Count <> arg_rCompare.Rows.Count _
Or arg_rStrings.Columns.Count <> arg_rCompare.Columns.Count Then
CONCATIF = CVErr(xlErrRef)
Exit Function
End If
If arg_rCompare.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = arg_rCompare.Value
Else
aData = arg_rCompare.Value
End If
If arg_rStrings.Cells.Count = 1 Then
ReDim aStrings(1 To 1, 1 To 1)
aStrings(1, 1) = arg_rStrings.Value
Else
aStrings = arg_rStrings.Value
End If
If IsArray(arg_vCriteria) Then
aCriteria = arg_vCriteria
ElseIf TypeName(arg_vCriteria) = "Range" Then
If arg_vCriteria.Cells.Count = 1 Then
ReDim aCriteria(1 To 1)
aCriteria(1) = arg_vCriteria.Value
Else
aCriteria = arg_vCriteria.Value
End If
Else
ReDim aCriteria(1 To 1)
aCriteria(1) = arg_vCriteria
End If
ReDim aResults(1 To arg_rCompare.Cells.Count)
ixResult = 0
For i = LBound(aData, 1) To UBound(aData, 1)
For j = LBound(aData, 2) To UBound(aData, 2)
For Each vCriteria In aCriteria
If aData(i, j) Like vCriteria Then
ixResult = ixResult + 1
aResults(ixResult) = aStrings(i, j)
End If
Next vCriteria
Next j
Next i
If ixResult > 0 Then
ReDim Preserve aResults(1 To ixResult)
CONCATIF = Join(aResults, arg_sDelimiter)
Else
CONCATIF = vbNullString
End If
Erase aData: aData = vbNullString
Erase aCriteria: aCriteria = vbNullString
Erase aResults
End Function
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
I was wondering what would be the most efficient way to create a UDF in VBA that concatenate an range from the worksheet with an additional character, let's say a comma.
I tried some variations, but I always get stuck with one problem, how to resize the array from the range selected in the worksheet automatically.
The bellow code works, but I believe there must be a more efficient way to do it.
Can you guys help me out, please?
Thanks.
Function conc(data As Range) As String
Dim hola() As Variant
t = data.Rows.Count
ReDim hola(1 To t)
a = 1
For Each i In data.Value
hola(a) = i & ","
a = a + 1
Next i
conc = Join(hola)
Erase hola
End Function
For concatenating many strings in one column and many rows (which is what your original is designed to do):
Function vconc(data As Range) As String
vconc = Join(Application.Transpose(data), Chr(44))
End Function
To concatenate many columns of strings in a single row:
Function hconc(data As Range) As String
hconc = Join(Application.Transpose(Application.Transpose(data)), Chr(44))
End Function
Don't know about more efficient. You can concatenate a specific column with
Public Function conc(ByVal data As Range) As String
conc = Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Index(data.Value, 0, 1)), ",")
End Function
The 1 indicates the column number of the array to concatenate.
Subject to limitations of index and transpose.
More than one column:
Public Function conc(ByVal data As Range) As String
Dim i As Long
For i = 1 To data.Columns.Count
conc = conc & Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Index(data.Value, 0, i)), ",")
Next i
End Function
This function I wrote some time back is pretty efficient and comprehensive...it handles 1d or 2d arrays, and you can skip blanks and add delimiters if you like. For an explanation and worked examples, see http://dailydoseofexcel.com/archives/2014/11/14/string-concatenation-is-like-the-weather/ and for a discussion on the efficiency benefits of the VBA JOIN function vs straight concatenation see http://excellerando.blogspot.com/2012/08/join-and-split-functions-for-2.html
Option Explicit
Public Function JoinText( _
InputRange As Range, _
Optional SkipBlanks As Boolean = False, _
Optional Delimiter As String = ",", _
Optional FieldDelimiter As String = ";", _
Optional EndDelimiter As String = vbNull, _
Optional Transpose As Boolean) As String
'Based on code from Nigel Heffernan at Excellerando.Blogspot.com
'http://excellerando.blogspot.co.nz/2012/08/join-and-split-functions-for-2.html
' Join up a 1 or 2-dimensional array into a string.
' ####################
' # Revision history #
' ####################
' Date (YYYYMMDD) Revised by: Changes:
' 20141114 Jeff Weir Turned into worksheet function, added FinalDelimiter and Transpose options
' 20141115 Jeff Weir Changed FinalDelimiter to EndDelimiter that accepts string, with default of ""
' 20150211 Jeff Weir Changed names of arguments and changed default orientation to Column=>Row
Dim InputArray As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim lngNext As Long
Dim i_lBound As Long
Dim i_uBound As Long
Dim j_lBound As Long
Dim j_uBound As Long
Dim arrTemp1() As String
Dim arrTemp2() As String
If InputRange.Rows.Count = 1 Then
If InputRange.Columns.Count = 1 Then
GoTo errhandler 'InputRange is a single cell
Else
' Selection is a Row Vector
InputArray = Application.Transpose(InputRange)
End If
Else
If InputRange.Columns.Count = 1 Then
' Selection is a Column Vector
InputArray = InputRange
Transpose = True
Else:
'Selection is 2D range. Transpose it, because our
' default input is data in rows
If Not Transpose Then
InputArray = Application.Transpose(InputRange)
Else: InputArray = InputRange
End If
End If
End If
i_lBound = LBound(InputArray, 1)
i_uBound = UBound(InputArray, 1)
j_lBound = LBound(InputArray, 2)
j_uBound = UBound(InputArray, 2)
ReDim arrTemp1(j_lBound To j_uBound)
ReDim arrTemp2(i_lBound To i_uBound)
lngNext = 1
For i = j_lBound To j_uBound
On Error Resume Next
If SkipBlanks Then
If Transpose Then
ReDim arrTemp2(i_lBound To WorksheetFunction.CountA(InputRange.Columns(i)))
Else
ReDim arrTemp2(i_lBound To WorksheetFunction.CountA(InputRange.Rows(i)))
End If
End If
If Err.Number = 0 Then
k = 1
For j = i_lBound To i_uBound
If SkipBlanks Then
If InputArray(j, i) <> "" Then
arrTemp2(k) = InputArray(j, i)
k = k + 1
End If
Else
arrTemp2(j) = InputArray(j, i)
End If
Next j
arrTemp1(lngNext) = Join(arrTemp2, Delimiter)
lngNext = lngNext + 1
Else:
Err.Clear
End If
Next i
If SkipBlanks Then ReDim Preserve arrTemp1(1 To lngNext - 1)
If lngNext > 2 Then
JoinText = Join(arrTemp1, FieldDelimiter)
Else: JoinText = arrTemp1(1)
End If
If JoinText <> "" Then JoinText = JoinText & EndDelimiter
errhandler:
End Function