Data grouping with macro

lind33

New Member
Joined
Jun 25, 2019
Messages
14
Office Version
  1. 2016
Platform
  1. Windows
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
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
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
 
Upvote 0
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:
Upvote 0
I know a little about scripting dictionaries, once I figure out what your code is doing, I will know more. Very compact. Very nice.
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0
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!
 
Upvote 0

Forum statistics

Threads
1,213,485
Messages
6,113,931
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top