Data grouping with macro

[lind33]

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

 

[MickG]

Try this for results from sheet "Data" "A7:N11" to sheets "Results" M7:Q11".

[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]

Add to a standard module. the workbook containing the data must be active when the code is run.

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

 

[pbornemeier]

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]

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.

 

[MickG]

You're very welcome !!

 

[lind33]

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]

Try this:-

[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]

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!

 

[MickG]

You're very welcome