Results 1 to 10 of 10

Thread: Data grouping with macro

  1. #1
    New Member
    Join Date
    Jun 2019
    Location
    Europe
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Data grouping with macro

    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/1bq5...ew?usp=sharing

  2. #2
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,734
    Post Thanks / Like
    Mentioned
    21 Post(s)
    Tagged
    10 Thread(s)

    Default Re: Data grouping with macro

    Try this for results from sheet "Data" "A7:N11" to sheets "Results" M7:Q11".
    Code:
    Sub MG25Jun38
    Dim Rng As Range, Dn As Range, n As Long, Rng2 As Range, nStr As String
    Dim Sp As Variant, Rw As Long, R As Range, ac As Long
    Rw = 5
    Set Rng = Sheets("Data").Range("A7:A11")
    Set Rng2 = Sheets("Results").Range("M1:Q1")
    With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    
    For Each Dn In Rng
        Rw = Rw + 1
        For ac = 0 To 13
            If Not .exists(Dn.Offset(, ac).Value) Then
                .Add Dn.Offset(, ac).Value, Dn.Offset(, ac).Value
            Else
                .Item(Dn.Offset(, ac).Value) = _
                .Item(Dn.Offset(, ac).Value) & "," & Dn.Offset(, ac).Value
            End If
        Next ac
        
        For Each R In Rng2
            Sp = Split(R, ",")
             For n = 0 To UBound(Sp)
                If .exists(Val(Sp(n))) Then
                     nStr = nStr & IIf(nStr = "", .Item(Val(Sp(n))), "," & .Item(Val(Sp(n))))
                End If
            Next n
            R.Offset(Rw).Value = nStr: nStr = ""
        Next R
    .RemoveAll
    Next Dn
    End With
    
    End Sub
    Regards Mick

  3. #3
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,580
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Data grouping with macro

    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 by pbornemeier; Jun 25th, 2019 at 08:36 AM. Reason: Moved comment
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  4. #4
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,580
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Data grouping with macro

    I know a little about scripting dictionaries, once I figure out what your code is doing, I will know more. Very compact. Very nice.
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  5. #5
    New Member
    Join Date
    Jun 2019
    Location
    Europe
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Data grouping with macro

    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.

  6. #6
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,734
    Post Thanks / Like
    Mentioned
    21 Post(s)
    Tagged
    10 Thread(s)

    Default Re: Data grouping with macro

    You're very welcome !!

  7. #7
    New Member
    Join Date
    Jun 2019
    Location
    Europe
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Data grouping with macro

    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.

  8. #8
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,734
    Post Thanks / Like
    Mentioned
    21 Post(s)
    Tagged
    10 Thread(s)

    Default Re: Data grouping with macro

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

  9. #9
    New Member
    Join Date
    Jun 2019
    Location
    Europe
    Posts
    7
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Data grouping with macro

    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!

  10. #10
    MrExcel MVP
    Join Date
    Jan 2008
    Posts
    14,734
    Post Thanks / Like
    Mentioned
    21 Post(s)
    Tagged
    10 Thread(s)

    Default Re: Data grouping with macro

    You're very welcome

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •