Sub CurlyAladinsEunuchstechretardRevisitedSept2015FTangFTangOLEBiscuitBarrel() '---o00o---`(_)`---o00o---
'http://www.mrexcel.com/forum/excel-questions/857924-compare-columns-display-whats-unique-separate-column-3.html
Rem 1) Get Some Worksheet data
' Dim vTemp As Variant'Just used sometimes for Debugging
Dim wsdbc As Worksheet 'Give variables Method, Properties etc, of Worksheets Object.
Set wsdbc = ThisWorkbook.Worksheets("CurlyAladinVBA") 'Assign the actual Worksheet to the Object. These two lines allow us to get at the Methods, properites etc by using the .Dot
Dim ldbc As Long, dbc As Long 'Variables for last "rows" and "rows" of interest. ( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster. )
Let ldbc = wsdbc.Cells(Rows.Count, 1).End(xlUp).Row 'The Range Object ( cell ) that is the last cell in the column of interest has the property .End ( argument Xl up ) appisd to it. This returns a new range ( cell ) which is that of the first Range ( cell ) with something in it "looking up" the XL spreadsheet from the last cell. Then the .Row Property is applied to return a long number equal to the row number of that cell
Dim arrIn() As Variant 'Variables for Dynamic Arrays for the Input Data including Headings
Let arrIn() = wsdbc.Range("A10:C" & ldbc & "").Value2 'The Property .value 2 applied to a range of more than 1 cell returns a colllection ( Array ) of the undelying values all the cells in that range. VBA allows a "one liner" to then assign these value to a dynamic Array. The Elements of the collection are defined initially as variant by VBA. So that is why we had Array() = Variant
Rem 2) Unique values of Animal Stuff. Prepare Microsoft Scripting Runtime Dictionary
'Using Microsoft Scripting Runtime Dictionary for a unique Key or referrence or heading value
'-needs library referrence MS Scripting Runtime ( Early Binding ) -
'Tools>>References>>scrolldown and check the box next to Microsoft Scripting Runtime
'... or crashes at next two lines
' Dim dicOb As Scripting.Dictionary ' Daten hier hat einem eindeutigen "Schlüssel" oder Teilenummer
' Set dicOb = New Scripting.Dictionary
'Alternative called Late binding. (But note some Dictionary methods and properties will not work with it - in those cases Early Binding must be used.)
Dim dicOb As Object
Set dicOb = CreateObject("Scripting.Dictionary") '' Late Binding is better when sharing files as I am here. Early Binding has the advantage that Excel intellisense
' will then work for the Microsoft Scripting Runtime stuff and give you suggestions after you type the .dot thing
'2a) Use a simple "one liner" to get unique Stuff
Dim z As Variant, Keys() As Variant 'For use with building of the unique referrences. Keys will be given by direct assignment to collection Field Of variant Types so must be Dimed as Variant. Similar to the .Range.Value thing
Dim j As Long 'Loop Bound variable Count for each Input "row"
For j = 2 To UBound(arrIn(), 1) '... look at each "row" starting at second, where the data starts
'Let vTemp = arrIn(j, 1)
'The method here =.Item() is a simple way to get unique Key ( referrence) values without actually assigning / putting anything in the dictionary http://www.snb-vba.eu/VBA_Dictionary_en.html ' -- Normallerweise .Item() verwendet man, um ein Element von eine eindeutiger Schlüssel, .Item, zu einem vaiable zuweisen, bzw. z = dicLookupTable.Item(x(i)) Wenn der Schlüssel aber nicht existiert, dann wird es gemacht - Cool oder ? --- ( Und kein Wert wird in die Variable angegeben werden ( aber das braucht auch Variable typ Variant) )
If arrIn(j, 1) <> "" And arrIn(j, 1) <> "Ignor this row" Then Let z = dicOb.Item(arrIn(j, 1) & "|" & arrIn(j, 2) & "||" & arrIn(j, 3)) 'use the concatenated first 3 columns in row as a Uniue stuff. you never see anything in z: Post #7 # 12 #14 http://www.excelforum.com/excel-programming-vba-macros/1083899-copy-and-paste-entire-row-to-second-sheet-based-on-cell-value.html
Next j
Let Keys() = dicOb.Keys 'This non Duplicate Key word / Heading / dictionary referrence / part number ( your unique stuff ) are obtainable from the Keys Property applied The Dictioary Object
Rem 3)Looping to get occurances=======
Dim y As Long 'Loop Bound variable Count
Dim arrOut() As Variant 'This is our Output Array. It is of known size and content type ( Long and strings , so need variant ) will be filled by looping so we can give it a type....
Dim pos1 As Long, pos11 As Long 'Positions of separators | || inn Keys(y) Concatenated String
ReDim arrOut(1 To UBound(Keys()) + 1 + 1, 1 To 4) '...we must use ReDim as Dim only takes numbers (First +1 makes space for headings, second +1 is because-***)
For y = 0 To UBound(Keys()) Step 1 'Take each Unique stuff in turn and....(-*** Internally Array type things tend to start by default at 0 - Keys(0) is first Key)
Let pos1 = InStr(1, Keys(y), "|"): Let pos11 = InStr(1, Keys(y), "||")
Let arrOut(y + 1 + 1, 1) = Left(Keys(y), (pos1 - 1)) 'Bit of mucking about to get..
Let arrOut(y + 1 + 1, 3) = Right(Keys(y), (Len(Keys(y)) - pos11) - 1) '.. at each of the 3 concatenated bits
Let arrOut(y + 1 + 1, 2) = Mid(Keys(y), (pos1 + 1), ((pos11 - pos1) - 1)) '.. and put them in the Output Array
For j = 2 To UBound(arrIn(), 1) Step 1 '.....consider each data "row" and ....
If Keys(y) = (arrIn(j, 1) & "|" & arrIn(j, 2) & "||" & arrIn(j, 3)) Then Let arrOut(y + 1 + 1, 4) = arrOut(y + 1 + 1, 4) + 1
Next j
Next y '===========================
Rem 4)Put headings in Output Array
Let arrOut(1, 1) = "UniqueRecord1": Let arrOut(1, 2) = "UniqueRecord2": Let arrOut(1, 3) = "UniqueRecord3": Let arrOut(1, 4) = "Occurances"
Rem 5)Output of Final Array values
Let wsdbc.Range("E10").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() 'The Resize Property Applied to this new Range Object Returns a new range object that of the last increased to the specified Row and Column size. This is a Neat way to paste out in one go: Shift then Resize the Range ( cell ) at top left of where output data should go to size of output array, then use the allowed VBA "One liner" to assign the values of an array to a spreadsheet range.
End Sub
