Data grouping with macro

lind33

New Member
Joined
Jun 25, 2019
Messages
7
I need help with a macro please.

I have a bunch of data on Data sheet A7:N11, a Results sheet where the outcome would be displayed on M7:Q11.
The data I have is repeating numbers between 1 and 12. I need to group these numbers on the table on the results page according to the M1:Q1.

I share a workbook example with sample data and sample results that I prepared manually. Please, the results should be displayed on M7:Q11 only, and the other cells should not be affected with the macro. I have other data on these cells.

https://drive.google.com/file/d/1bq57vPEp_ieOk5UBF7qcWDkLPHb9G5dq/view?usp=sharing
 

Some videos you may like

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this for results from sheet "Data" "A7:N11" to sheets "Results" M7:Q11".
Code:
[COLOR="Navy"]Sub[/COLOR] MG25Jun38
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rng2 [COLOR="Navy"]As[/COLOR] Range, nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range, ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Rw = 5
[COLOR="Navy"]Set[/COLOR] Rng = Sheets("Data").Range("A7:A11")
[COLOR="Navy"]Set[/COLOR] Rng2 = Sheets("Results").Range("M1:Q1")
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Rw = Rw + 1
    [COLOR="Navy"]For[/COLOR] ac = 0 To 13
        [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Offset(, ac).Value) [COLOR="Navy"]Then[/COLOR]
            .Add Dn.Offset(, ac).Value, Dn.Offset(, ac).Value
        [COLOR="Navy"]Else[/COLOR]
            .Item(Dn.Offset(, ac).Value) = _
            .Item(Dn.Offset(, ac).Value) & "," & Dn.Offset(, ac).Value
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] ac
    
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Rng2
        Sp = Split(R, ",")
         [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
            [COLOR="Navy"]If[/COLOR] .exists(Val(Sp(n))) [COLOR="Navy"]Then[/COLOR]
                 nStr = nStr & IIf(nStr = "", .Item(Val(Sp(n))), "," & .Item(Val(Sp(n))))
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] n
        R.Offset(Rw).Value = nStr: nStr = ""
    [COLOR="Navy"]Next[/COLOR] R
.RemoveAll
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,807
Add to a standard module. the workbook containing the data must be active when the code is run.

Code:
Option Explicit

Sub ExtractData()
    'https://www.mrexcel.com/forum/excel-questions/1102099-data-grouping-macro.html

    Dim rngData As Range
    Dim rngCategories As Range
    Dim rngResults As Range
    Dim aryColumns(1 To 12) As Long
    Dim lIndex As Long
    Dim oFound As Object
    Dim aryTemp As Variant
    Dim lSplitIndex As Long
    
    Dim rngCell As Range
    
    Set rngData = Worksheets("Data").Range("A7:N11")
    Set rngResults = Worksheets("Results").Range("M7:Q11")
    Set rngCategories = Worksheets("Results").Range("M1:Q1")
    
    rngResults.Cells.ClearContents
    
    'Column Matrix
    For lIndex = 13 To 17
         aryTemp = Split(Worksheets("Results").Cells(1, lIndex), ",")
         For lSplitIndex = LBound(aryTemp) To UBound(aryTemp)
            aryColumns(aryTemp(lSplitIndex)) = lIndex
         Next
    Next
    
    'Process
    For Each rngCell In rngData.Cells
        Worksheets("Results").Cells(rngCell.Row, aryColumns(rngCell.Value)) = _
            Worksheets("Results").Cells(rngCell.Row, aryColumns(rngCell.Value)) & _
            "," & rngCell.Value
    Next
    
    For Each rngCell In rngResults.Cells
        If rngCell.Value <> vbNullString Then
            'Remove leading comma
            rngCell.Value = Mid(rngCell.Value, 2)
            'Sort Results
            aryTemp = Split(rngCell, ",")
            aryTemp = BubbleSortArray(aryTemp)
            rngCell.ClearContents
            For lIndex = LBound(aryTemp) To UBound(aryTemp)
                rngCell.Value = rngCell.Value & "," & aryTemp(lIndex)
            Next
            rngCell.Value = Mid(rngCell.Value, 2)
        End If

    Next
    
End Sub

Function BubbleSortArray(ary As Variant)
    'Force as numbers
    
    Dim lX As Long, lY As Long
    Dim varTemp As Variant
    
    For lX = LBound(ary) To UBound(ary) - 1
        For lY = lX + 1 To UBound(ary)
            If CInt(ary(lX)) > CInt(ary(lY)) Then
                varTemp = CInt(ary(lY))
                ary(lY) = CInt(ary(lX))
                ary(lX) = varTemp
            End If
        Next
    Next
    BubbleSortArray = ary
    
End Function
 
Last edited:

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,807
I know a little about scripting dictionaries, once I figure out what your code is doing, I will know more. Very compact. Very nice.
 

lind33

New Member
Joined
Jun 25, 2019
Messages
7
Thank you, MickG and Pbornemeier, I tested both of your codes, and both works like a charm. I will test a little futher. If I have any questions, I may ask later if you don't mind, please. Thanks again.
 

lind33

New Member
Joined
Jun 25, 2019
Messages
7
MickG, is it possible to limit
Set Rng = Sheets("Data").Range("A7:A11") this to A7:N11? please. When I changed A11 to N11, I got strange a result set.
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG25Jun58
'[COLOR="Green"][B]code2[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rng2 [COLOR="Navy"]As[/COLOR] Range, nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range, ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Rw = 5
[COLOR="Navy"]Set[/COLOR] Rng = Sheets("Data").Range("A7:N11")
[COLOR="Navy"]Set[/COLOR] Rng2 = Sheets("Results").Range("M1:Q1")
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]Dim[/COLOR] t
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
   [COLOR="Navy"]If[/COLOR] Not Temp = Dn.Row [COLOR="Navy"]Then[/COLOR]
        .RemoveAll
        Rw = Rw + 1
    [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]If[/COLOR] Not .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            .Add Dn.Value, Dn.Value
        [COLOR="Navy"]Else[/COLOR]
            .Item(Dn.Value) = _
            .Item(Dn.Value) & "," & Dn.Value
        [COLOR="Navy"]End[/COLOR] If
 
    [COLOR="Navy"]If[/COLOR] Dn.Column = 14 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Rng2
            Sp = Split(R, ",")
                [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
                    [COLOR="Navy"]If[/COLOR] .exists(Val(Sp(n))) [COLOR="Navy"]Then[/COLOR]
                        nStr = nStr & IIf(nStr = "", .Item(Val(Sp(n))), "," & .Item(Val(Sp(n))))
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]Next[/COLOR] n
                 R.Offset(Rw).Value = nStr: nStr = ""
        [COLOR="Navy"]Next[/COLOR] R
    [COLOR="Navy"]End[/COLOR] If
    Temp = Dn.Row
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

lind33

New Member
Joined
Jun 25, 2019
Messages
7
I'm sorry that this required you to change the code all together. thanks a lot for your time and help again. You have a lovely day!
 

Watch MrExcel Video

Forum statistics

Threads
1,099,177
Messages
5,467,063
Members
406,521
Latest member
MIKE1122

This Week's Hot Topics

Top