I have a macro that creates a dictionary with over 30k entries, My problem now is that I would like to have these entries show in columns in excel Excel has a maximum number of column entries that doesn't allow me to put my keys in and then transpose them. I would like all the keys to be in one column and all the values in another.
Question: Is there a way around this?
Sub HTH()
Dim vArray As Variant
Dim lLoop As Long
Dim rCell As Range
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For Each rCell In Range("B1:I3022")
vArray = Split(rCell.Value, " ")
For lLoop = LBound(vArray) To UBound(vArray)
If Not .Exists(vArray(lLoop)) Then
.Add vArray(lLoop), 1
Else
.Item(vArray(lLoop)) = .Item(vArray(lLoop)) + 1
End If
Next lLoop
Next rCell
MsgBox ("there are " & .Count & "Keys")
Dim keyArray, itemArray, resultArray
keyArray = .Keys
itemArray = .Items
ReDim resultArray(LBound(keyArray) To UBound(keyArray), 0 To 1)
For i = LBound(keyArray) To UBound(keyArray)
resultArray(i, 0) = keyArray(i)
resultArray(i, 1) = itemArray(i)
Next i
Range("L1").Resize(UBound(resultArray) + 1, 2) = resultArray
End With
End Sub
Related
I have the following macro that I got from someone, and trying to modify it to suit my purpose.
I'm trying to alter this macro to find and highlight cells that have duplicate values within each cell,
for example, it should highlight B62 and B63 (green),
and color font red the duplicate values (i.e. B_HWY_1010 in B62, and B_HWY_1015 in B63)
Sub Dupes()
Dim d As Object
Dim a As Variant, itm As Variant
Dim i As Long, k As Long
Dim rng As Range
Dim bColoured As Boolean
Set d = CreateObject("Scripting.Dictionary")
Set rng = Range("B1", Range("B" & Rows.Count).End(xlUp))
a = rng.Value
For i = 1 To UBound(a)
For Each itm In Split(a(i, 1), ",")
d(itm) = d(itm) + 1
Next itm
Next i
Application.ScreenUpdating = False
For i = 1 To UBound(a)
k = 1
bColoured = False
For Each itm In Split(a(i, 1), ",")
If d(itm) > 1 Then
If Not bColoured Then
rng.Cells(i).Interior.Color = vbGreen
bColoured = True
End If
rng.Cells(i).Characters(k, Len(itm)).Font.Color = RGB(244, 78, 189)
End If
k = k + Len(itm) + 1
Next itm
Next i
Application.ScreenUpdating = True
End Sub
Any help or advise is appreciated.
The following will do that
Option Explicit
Public Sub Example()
Dim Cell As Range
For Each Cell In Range("A1:A10")
HighlightRepetitions Cell, ", "
Next Cell
End Sub
Private Sub HighlightRepetitions(ByVal Cell As Range, ByVal Delimiter As String)
If Cell.HasFormula Or Cell.HasArray Then Exit Sub ' don't run on formulas
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dim Data() As String
Data = Split(Cell.Value, Delimiter) ' split data in the cell by Delimiter
Dim StrLen As Long ' length of the string that was already processed
Dim i As Long
For i = LBound(Data) To UBound(Data) ' loop through all data items
Dim DataLen As Long
DataLen = Len(Data(i)) 'get length of current item
If Dict.Exists(Data(i)) Then
' item is a repetition: color it
Cell.Characters(StrLen + 1, DataLen).Font.Color = vbRed
Cell.Interior.Color = vbGreen
Else
' item is no repetition: add it to the dictionary
Dict.Add Data(i), Data(i)
End If
StrLen = StrLen + DataLen + Len(Delimiter) ' calculate the length of the processed string and add length of the delimiter
Next i
End Sub
The following items would be colored:
You can turn ScreenUpdating off before looping in Sub Example() and turn on after the loop to stop it from flickering. Note this will not run on formuas, as parts of formula results cannot be colored. This can be prevented by using If Cell.HasFormula Or Cell.HasArray Then Exit Sub as first line.
Please, try the next code, too:
Sub findComaDelDuplicates()
Dim sh As Worksheet, arr, itm, arrInt, i As Long, rngS As Range, pos As Long
Dim arrDif As Long, j As Long, startPos As Long, arrPos, k As Long, mtch
Set sh = ActiveSheet
With sh.Range("B1", Range("B" & sh.rows.count).End(xlUp))
arr = .value 'put the range value in an array to make the iteration faster
.ClearFormats 'clear previous format
.Font.Color = vbBlack 'make the font color black
End With
For i = 1 To UBound(arr) 'iterate between the array elements:
arrInt = Split(arr(i, 1), ",") 'split the content by comma delimiter
ReDim arrPos(UBound(arrInt)) 'redim the array keeping elements already formatted
For Each itm In arrInt 'iterate between the comma separated elements
arrDif = UBound(arrInt) - 1 - UBound(Filter(arrInt, itm, False)) 'find how many times an element exists
If arrDif > 0 Then 'if more then an occurrence:
If rngS Is Nothing Then 'if range to be colored (at once) does not exist:
Set rngS = sh.Range("B" & i) 'it is crated
Else
Set rngS = Union(rngS, sh.Range("B" & i)) 'a union is made from the previous range and the new one
End If
mtch = Application.match(itm, arrPos, 0) 'check if the itm was already processed:
If IsError(mtch) Then 'if itm was not processed:
For j = 1 To arrDif + 1 'iterate for number of occurrences times
If j = 1 Then startPos = 1 Else: startPos = pos + 1 'first time, inStr starts from 1, then after the first occurrence
pos = InStr(startPos, sh.Range("B" & i).value, itm) 'find first character position for the itm to be colored
sh.Range("B" & i).Characters(pos, Len(itm)).Font.Color = vbRed 'color it
Next j
arrPos(k) = itm 'add the processed itm in the array
End If
End If
Next
Erase arrInt 'clear the array for the next cell value
Next i
If Not rngS Is Nothing Then rngS.Interior.Color = vbGreen 'color the interior cells of the built range
End Sub
Attention: The above code puts the range in an array to iterate much faster. But, if the range does not start form the first row, the cells to be processed must be obtained by adding to i the rows up to the first of the range. The code can be adapted to make this correlation, but I am too lazy to do it now...:)
So I have stored all variables in a string and then try to pass that on to the Autofilter criteria, but to no avail.
Sub TestAutoFilter()
'Filter based on column Importance.
'PURPOSE: Dynamically Create Array Variable based on a Given Size
Dim myArray() As Variant
Dim DataRange As Range
Dim cell As Range
Dim x As Long
'Determine the data you want stored
Set DataRange = ActiveSheet.UsedRange
'Resize Array prior to loading data
'Loop through each cell in Range and store value in Array
counter = 0
For Each chkbx In ThisWorkbook.Sheets("Sheet1").CheckBoxes
If chkbx.Value > 0 And InStr(1, LCase(chkbx.Name), "check") <> 0 Then
counter = counter + 1
End If
Next chkbx
ReDim myArray(counter)
For Each chkbox In ThisWorkbook.Sheets("Sheet1").CheckBoxes
If chkbox.Value > 0 And InStr(1, LCase(chkbox.Name), "check") <> 0 Then
myArray(x) = chkbox.Caption
x = x + 1
End If
Next chkbox
myArrayString = ""
'Print values to Immediate Window (Ctrl + G to view)
For x = LBound(myArray) To counter
myArrayString = myArrayString & "," & myArray(x)
Next x
'Debug.Print (myArrayString)
myRightString = Left(myArrayString, Len(myArrayString) - 1)
myLeftString = Right(myRightString, Len(myRightString) - 1)
'Debug.Print (RTrim(myLeftString))
ThisWorkbook.Sheets("Data").Range("A3:F3").AutoFilter Field:=3, _
Criteria1:=Array(myLeftString), _
Operator:=xlFilterValues
End Sub
I also tried to replace myLeftstring with the actual array as such Criteria1:=myArray but that also didn't work.
Here is what I am trying to accomplish:
I have an ID in Column DA. I have a product in Column CB. I want to count the number of unique products for each ID (ID can have multiple lines). I then want to write the number of unique products to a new column (DB).
My logic was to write two dictionaries. The "main" dictionary would be keyed to the ID and the second dictionary would be keyed to my products. In the main dictionary, if the key exists I would retrieve the item into a dict object, if it doesn't exist then I'd re-write the main dictionary.
After this, I was thinking of using .count function to tell me how many unique values existed for each ID.
I have been trying to adapt some code to fit my needs. Here is what I have currently:
Sub Find_Unique_Product_Number()
Dim LastRow As Long
LastRow = Worksheets("Orders").Range("A" & Rows.Count).End(xlUp).Row
adata = Worksheets("Orders").Range("A1:DB" & LastRow)
Set dicTwoProds = CreateObject("Scripting.Dictionary") 'Late binding creation of dictionary
For LastRow = LBound(adata, 1) To UBound(adata, 1)
sKey1 = adata(LastRow, 80)
If Not dicTwoProds.Exists(sKey) Then
Set dicItem = CreateObject("Scripting.Dictionary")
dicTwoProds.Add sKey1, aItem
sKey1 = Worksheets("Orders").Range("CB2:CB" & LastRow) 'Product
dicTwoProdsItem.Add sKey1, ""
Else
Set dicItem = dicTwoProd.Item(sKey)
sKey2 = Worksheets("Orders").Range("CB2:CB" & LastRow) 'Product
If Not dicItem.Exists(sKey2) Then
dicItem.Add sKey2, ""
dicTwoProds.Item(sKey) = aItem
End If
End If
Next
End Sub
Currently this code throws an "object required" error on this line: dicTwoProdsItem.Add sKey1, ""
I am guessing part of my issue is how I am using .range on the sKey lines? I am unsure of how that syntax should be.
I am not sure how writing the .count results to the sheet would work at all yet.
I do have an array formula that does what I need which is this:
'=SUM(IF(DA5=DA2:DA100,1/ (COUNTIFS(DA2:DA100,DA5,CB2:CB100,CB2:CB100)),0))
The formula is extremely slow which is part of the reason I wanted to use dictionaries. If the dictionary solution does not work, I would be interested in assistance with the syntax for using VBA to place the array formula into Column DB on my worksheet.
All data is on the same worksheet in the described scenario.
Cheers!
You can use a single Dictionary to count the number of unique products for each ID.
The trick is to concatenate the id with the product to create a unique key:
Dim dict As Object, lastRow As Long, r As Long, ids(), products(), dupIds()
Set dict = CreateObject("Scripting.Dictionary")
lastRow = Worksheets("Orders").Cells(Rows.Count, 1).End(xlUp).Row
ids = Worksheets("Orders").Range("DA2:DA" & lastRow).Value
products = Worksheets("Orders").Range("CB2:CB" & lastRow).Value
' map the id to each unique id/product '
For r = LBound(ids) To UBound(ids)
dict(ids(r, 1) & products(r, 1)) = CStr(ids(r, 1))
Next
' map the count of products to each unique id '
dupIds = dict.Items
dict.RemoveAll
For r = LBound(dupIds) To UBound(dupIds)
dict(dupIds(r)) = dict(dupIds(r)) + 1
Next
' build the column holding the count of products '
For r = LBound(ids) To UBound(ids)
products(r, 1) = dict(CStr(ids(r, 1)))
Next
Worksheets("Orders").Range("DB2:DB" & lastRow).Value = products
If I'm understanding you correctly something like this should work.
(Simplified for a 2-column dataset)
Sub Find_Unique_Product_Number()
Dim dict As Object, i As Long, id, prod, adata, k, k2
Dim rngDest As Range
Set dict = CreateObject("Scripting.Dictionary")
With Worksheets("Orders")
adata = Worksheets("Orders").Range("A1:B" & _
.Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
For i = LBound(adata, 1) To UBound(adata, 1)
id = adata(i, 1)
prod = adata(i, 2)
If Len(id) > 0 And Len(prod) > 0 Then
'New id? Add as key with empty dictionary
If Not dict.exists(id) Then dict.Add id, CreateObject("Scripting.Dictionary")
'increment the count for this combination
dict(id)(prod) = dict(id)(prod) + 1
End If
Next
'EDIT: output the counts
Set rngDest = Worksheets("Summary").Range("A2")
For Each k In dict.keys
For Each k2 In dict(k).keys
rngDest.Resize(1, 3).Value = Array(k, k2, dict(k)(k2))
Set rngDest = rngDest.Offset(1, 0)
Next k2
Next
End Sub
I currently have an array which I populate and paste in a sheet named "T1" using a macro. My current macro uses the rowcount function to determine the used rows and pastes the array from the next available row.
The problem I am having is that when I paste this array multiple times, the arrays need to be spaced by a row so that i can differentiate different submissions. This is what I have so far, and I was hoping someone could help me with this:
Sub CopyData()
Dim Truearray() As String
Dim cell As Excel.Range
Dim RowCount1 As Integer
Dim i As Integer
Dim ii As Integer
Dim col As Range
Dim col2 As Range
i = 0
ii = 2
RowCount1 = DHRSheet.UsedRange.Rows.Count
Set col = DHRSheet.Range("I1:I" & RowCount1)
For Each cell In col
If cell.Value = "True" Then
Dim ValueCell As Range
Set ValueCell = Cells(cell.Row, 3)
ReDim Preserve Truearray(i)
Truearray(i) = ValueCell.Value
Dim siblingCell As Range
Set siblingCell = Cells(cell.Row, 2)
Dim Siblingarray() As String
ReDim Preserve Siblingarray(i)
Siblingarray(i) = DHRSheet.Name & "$" & siblingCell.Value
i = i + 1
End If
Next
Dim RowCount2 As Integer
RowCount2 = DataSheet.UsedRange.Rows.Count + 1
For ii = 2 To UBound(Truearray)
DataSheet.Cells(RowCount2 + ii, 2).Value = Truearray(ii)
Next
For ii = 2 To UBound(Siblingarray)
DataSheet.Cells(RowCount2 + ii, 1).Value = Siblingarray(ii)
Next
DataSheet.Columns("A:B").AutoFit
MsgBox ("Data entered has been successfully validated & logged")
End Sub
If you Offset two rows from the bottom cell, you will leave a blank row of separation. You should also consider filling the whole array as base 1 and writing it to DataSheet in one shot.
Sub CopyData2()
Dim rCell As Range
Dim aTrues() As Variant
Dim rRng As Range
Dim lCnt As Long
'Define the range to search
With DHRSheet
Set rRng = .Range(.Cells(1, 9), .Cells(.Rows.Count, 9).End(xlUp))
End With
'resize array to hold all the 'trues'
ReDim aTrues(1 To Application.WorksheetFunction.CountIf(rRng, "True"), 1 To 2)
For Each rCell In rRng.Cells
If rCell.Value = "True" Then
lCnt = lCnt + 1
'store the string from column 2
aTrues(lCnt, 1) = DHRSheet.Name & "$" & rCell.Offset(0, -7).Value
'store the value from column 3
aTrues(lCnt, 2) = rCell.Offset(0, -6).Value
End If
Next rCell
'offset 2 from the bottom row to leave a row of separation
With DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp).Offset(2, 0)
'write the stored information at one time
.Resize(UBound(aTrues, 1), UBound(aTrues, 2)).Value = aTrues
End With
End Sub
I am new to Excel VBA Programming. I have one excel sheet with two columns and each column has some email adresses separated by ##. like
ColumA
aa#yahoo.com##bb#yahoo.com##cc#yahoo.com
x#.com##y#y.com
ColumnB
zz#yahoo.com##aa#yahoo.com
aa#yahoo.com
As you can see that both column has two rows, I need 3rd column that should contain all the unique values like
ColumnC
aa#yahoo.com##bb#yahoo.com##cc#yahoo.com#zz#yahoo.com
x#.com##y#y.com##aa#yahoo.com
Thanks
Something like this with variant arrays and a dictionary is an efficient process of getting your desired outcome
[updated to remove delimiter at front of string, code is flexible on delimiter length]
SO seems to have removed the ability to upload image so my picture has fallen off ....
Sub GetUniques()
Dim strDelim As String
Dim X
Dim Y
Dim objDic As Object
Dim lngRow As Long
Dim lngRow2 As Long
strDelim = "##"
Set objDic = CreateObject("scripting.dictionary")
X = Range([a1], Cells(Rows.Count, "B").End(xlUp)).Value2
For lngRow = 1 To UBound(X, 1)
X(lngRow, 1) = X(lngRow, 1) & strDelim & X(lngRow, 2)
Y = Split(X(lngRow, 1), strDelim)
X(lngRow, 1) = vbNullString
For lngRow2 = 0 To UBound(Y, 1)
If Not objDic.exists(lngRow & Y(lngRow2)) Then
X(lngRow, 1) = X(lngRow, 1) & (strDelim & Y(lngRow2))
objDic.Add (lngRow & Y(lngRow2)), 1
End If
Next lngRow2
If Len(X(lngRow, 1)) > Len(strDelim) Then X(lngRow, 1) = Right(X(lngRow, 1), Len(X(lngRow, 1)) - Len(strDelim))
Next lngRow
[c1].Resize(UBound(X, 1), 1).Value2 = X
End Sub
Here's my take. How it works:
Dump columnA and B into a variant array
Combine each row, split into an array of emails, then weed out dupes with a dictionary.
Combine unique list into a single string and store in a new array
Transpose the new array onto column C.
Sub JoinAndUnique()
Application.ScreenUpdating = False
Dim varray As Variant, newArray As Variant
Dim i As Long, lastRow As Long
Dim temp As Variant, email As Variant
Dim newString As String, seperator As String
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
seperator = "##"
lastRow = range("A" & Rows.count).End(xlUp).Row
varray = range("A1:B" & lastRow).Value
ReDim newArray(1 To UBound(varray, 1))
On Error Resume Next
For i = 1 To UBound(varray, 1)
temp = Split(varray(i, 1) & seperator & varray(i, 2), seperator)
For Each email In temp
If Not dict.exists(email) Then
dict.Add email, 1
newString = newString & (seperator & email)
End If
Next
newArray(i) = Mid$(newString, 3)
dict.RemoveAll
newString = vbNullString
Next
range("C1").Resize(UBound(newArray)).Value = Application.Transpose(newArray)
Application.ScreenUpdating = True
End Sub
Note:
It's fairly similar to brettdj's answer, but there are a few differences worth mentioning:
I used more meaninful names for variables (for readability and to make it easier to edit)
I do clean up of the "##" at the start of the sentence
I use a new array rather than overwrite the values of an existing one
I choose to clear the dictionary after each cell
I choose to use "on error resume next" and just dump entries into the dictionary instead of checking if they exist or not (personal preference, makes no major difference)
The easiest way to do this would be to use the dictionary object, split function, and join function. Of course, you don't need to use those exact ones, but give it a try and see what you get.