• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Combining groups of numbers into lists, with no duplicates.

D

dwrowe001

Member
Hi everyone,
I have 4 groups of numbers fo varying quantities, up to 30 possible in each group. I would like to be able to have each group of numbers combined into separate lists as depicted in the attached example. eliminating duplicates and numbers above 60.

Combine the numbers in Group 1, D7:M9 into list in Column N. Same for Group 2 D11:m13, put into list in column O. Group 3 in column P and Group 4 in Column Q. No duplicate numbers in any list. No double zeros, and no numbers above 60. Then combine columns N, O, P, Q into one main list in Column R. I know this is an extra step, when it's possible to go from the group lists to the main list. I would like however to have each group list broken out first, then from there go to the main list. No duplicate numbers and no numbers above 60. If possible remove leading zeros on single digit numbers.

The numbers in each group are always changing. So I was thinking of having a button to click to update the number lists when the group numbers change.

I am trying to learn VBA.. if someone does help me with this, could you break down how it works?
Thank you,
Dave
 

Attachments

  • Groups.xlsx
    15.5 KB · Views: 8
Test on backup copy of activesheet. Run from activesheet. Put code in Module.
Code: 
Sub Main()
    Dim a, b, c, i As Integer, r As Range
    a = Split("D7:M9,D11:M13,D15:M17,D19:M21,D7:M21", ",")
    b = Split("O7,P7,Q7,R7,S7", ",")
    For i = 0 To UBound(a)
        c = aISortNoDupsNoBlanksNoZeros(a(i))
        Set r = Range(b(i), Cells(Rows.Count, Range(b(i)).Column).End(xlUp))
        If r(1).Row < 7 Then Set r = Range(b(i))
        r.ClearContents
        r(1).Resize(UBound(c) + 1) = WorksheetFunction.Transpose(c)
    Next i
End Sub

Function aISortNoDupsNoBlanksNoZeros(r)
    Dim a, i As Integer
    a = RangeTo1dArray(Range(r))
    For i = 0 To UBound(a)
        a(i) = CInt(a(i))
        If a(i) = 0 Then a(i) = ""
    Next i
    
    a = UniqueArrayByDict(a, , True)
    a = ArrayListSort(a)
    aISortNoDupsNoBlanksNoZeros = a
End Function

' http://www.excelforum.com/excel-programming-vba-macros/819998-filter-and-sort-scripting-dictionary.html
' Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0, _
  Optional tfStripBlanks = False) As Variant
  Dim dic As Object 'Late Binding method - Requires no Reference
  Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
  'Dim dic As Dictionary     'Early Binding method
  'Set dic = New Dictionary  'Early Binding Method
  Dim e As Variant
  dic.CompareMode = compareMethod
  'BinaryCompare=0
  'TextCompare=1
  'DatabaseCompare=2
  For Each e In Array1d
    If Not dic.Exists(e) Then
      If tfStripBlanks And e <> "" Then dic.Add e, Nothing
    End If
  Next e
  UniqueArrayByDict = dic.Keys
End Function

Function RangeTo1dArray(aRange As Range) As Variant
  Dim a() As Variant, c As Range, i As Long
  ReDim a(0 To aRange.Cells.Count - 1)
  i = i - 1
  For Each c In aRange
    i = i + 1
    a(i) = c
  Next c
  RangeTo1dArray = a()
End Function

'http://www.vbaexpress.com/forum/showthread.php?48491
Function ArrayListSort(sn As Variant, Optional bAscending As Boolean = True)
    With CreateObject("System.Collections.ArrayList")
        Dim cl As Variant
        For Each cl In sn
            .Add cl
        Next
        
        .Sort 'Sort ascendending
        If bAscending = False Then .Reverse 'Sort and then Reverse to sort descending
        ArrayListSort = .Toarray()
    End With
End Function
 
Hi Dave !​
​
Many errors in your attachment result lists ! Seriously …​
​
This unique 1-60 little demonstration well works only without the useless merged cells starting at cell C24 (so unmerge them !) :​
Code: 
Sub Demo1()
  Const SCA = "System.Collections.ArrayList"
    Dim Obj(1) As Object, R&, C%, V
    Set Obj(0) = CreateObject(SCA):  Set Obj(1) = CreateObject(SCA)
        [O6].CurrentRegion.Offset(1).Clear
        R = 3
    For C = 1 To 4
            R = R + 4
        For Each V In Cells(R, 4).CurrentRegion.Value2
                 V = Val(V)
              If V > 0 And V < 61 Then If Not Obj(0).Contains(V) Then Obj(0).Add V: If Not Obj(1).Contains(V) Then Obj(1).Add V
        Next
            Obj(0).Sort
            Cells(7, 14 + C).Resize(Obj(0).Count).Value2 = Application.Transpose(Obj(0).ToArray)
            Obj(0).Clear
    Next
        Obj(1).Sort
        Cells(7, 14 + C).Resize(Obj(1).Count).Value2 = Application.Transpose(Obj(1).ToArray)
        Obj(1).Clear
        Erase Obj
End Sub
Do you like it ? So thanks to click on bottom right Like !​
​
 
To salim hasan : according to what I told you 'for a clean code' in another recent thread​
my revamped 1-60 demonstration showing the two classic ways to manage an object :​
Code: 
Sub Demo1r()
  Const SCA = "System.Collections.ArrayList"
    Dim Obj As Object, R&, C%, V
    Set Obj = CreateObject(SCA)
        [O6].CurrentRegion.Offset(1).Clear
        R = 3
    With CreateObject(SCA)
        For C = 1 To 4
                R = R + 4
            For Each V In Cells(R, 4).CurrentRegion.Value2
                     V = Val(V)
                  If V > 0 And V < 61 Then If Not .Contains(V) Then .Add V: If Not Obj.Contains(V) Then Obj.Add V
            Next
               .Sort
                Cells(7, 14 + C).Resize(.Count).Value2 = Application.Transpose(.ToArray)
               .Clear
        Next
    End With
        Obj.Sort
        Cells(7, 14 + C).Resize(Obj.Count).Value2 = Application.Transpose(Obj.ToArray)
        Obj.Clear
    Set Obj = Nothing
End Sub
You may Like it !​
​
 
Marc L, thank you for the code.. it worked like a charm.
I apologize for the errors and duplicate wording in the attached example and wording of my original post. The attachment was provide merely for example purposes to help explain what I needed. I didn't realize it would pose a problem. I do thank you for your work.
Dave
 
Last edited by a moderator:
Hi Ken,
I tried your code, but the lists it produced didn't eliminate numbers above 60. Thank you also for the work..
Dave
 
According to this PM …​
dwrowe001 said:
How does the code know where to go to get the numbers of each group.

How does the code know where to paste the numbers retrieved from the groups
Click to expand...
… some clarification :​
  • follow the variable R - as a Row index - for where to get each group numbers.

  • see the variable C - as a Column index - for where to paste each list.
​
I chose the ArrayList Windows object to store each list for convenience but even a beginner can achieve this need​
only with some Excel basics features - copy data in column, sort, remove duplicates - or via a pure VBA way​
just using a Collection object instead of any external object (ArrayList, Dictionary, …).​
​
 
FWIW, my code is easily modified to add the elimination of > 60 values.
Code: 
Function aISortNoDupsNoBlanksNoZeros(r)
    Dim a, i As Integer
    a = RangeTo1dArray(Range(r))
    For i = 0 To UBound(a)
        a(i) = CInt(a(i))
        If a(i) = 0 Then a(i) = ""
        If a(i) > 60 Then a(i) = ""
    Next i
    
    a = UniqueArrayByDict(a, , True)
    a = ArrayListSort(a)
    aISortNoDupsNoBlanksNoZeros = a
End Function
 
You must log in or register to reply here.
Back
Top