Grouping of similar data by Macros possible??

Originally Posted by Winon

@ Richard Buttrey,

I was about to ask the same question. Tolerances should be consistent even if variations are applied.

Kind Regards.

Helo winon...explained calculations and attached sample sheet. Please find.

Thank you.

Originally Posted by Kaper

Here is formulas - handwork based solution, which could be used as a startpoint for macro:

Hi sir,
Thank you for your kind response. i have tried but not getting results. can you share the sheet with formulas?

for the convince and reducing process i have modified sample format. please find modified sample file.

Thank you for helping..

Originally Posted by Kaper

Here is formulas - manual sort based solution, which could be used as a startpoint for macro:

See attached file for the macro. But I do strongly recommend you go through formulas version first to find how it works.

Thank You Kaper..nice idea for quick analysis.

Thank you for helping

Try

Sub test()
    Dim a, e, i As Long, ii As Long, txt As String, temp, w, x(), y, n
    With Sheets("sheet1")
        With Intersect(.Columns("b:o"), .UsedRange)
            a = Application.Index(.Value, Evaluate("row(1:" & _
            .Rows.Count & ")"), [{1,3,4,9,14,10,11,14}])
            a(1, 1) = a(1, 1) & " Grouping"
            a(1, 8) = "No. of Column/Wall"
        End With
    End With
    VSortM a, 2, UBound(a, 1), 5
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If a(i, 1) <> "" Then
                For Each e In Array(2, 3)
                    txt = txt & Chr(2) & a(i, e)
                Next
                If IsEmpty(.Item(txt)) Then
                    ReDim w(1 To 1)
                Else
                    w = .Item(txt)
                    ReDim Preserve w(1 To UBound(w) + 1)
                End If
                w(UBound(w)) = Application.Index(a, i, 0)
                .Item(txt) = w
            End If
            txt = ""
        Next
        For Each e In .items
            If UBound(e) > 1 Then
                n = n + 1: ReDim Preserve x(1 To n)
                temp = e(1)(UBound(e(1))) * 0.87
                x(n) = e(1): y = x(n)
                For i = 2 To UBound(e)
                    If e(i)(UBound(e(i))) >= temp Then
                        y(1) = y(1) & "," & e(i)(1)
                    Else
                        Exit For
                    End If
                Next
                y(UBound(y)) = UBound(Split(y(1), ",")) + 1: x(n) = y
                If i <= UBound(e) Then
                    n = n + 1: ReDim Preserve x(1 To n)
                    x(n) = e(i): y = x(n)
                    For ii = i + 1 To UBound(e)
                        y(1) = y(1) & "," & e(ii)(1)
                    Next
                    y(UBound(y)) = UBound(Split(y(1), ",")) + 1
                    x(n) = y
                End If
            Else
                n = n + 1: ReDim Preserve x(1 To n)
                e(1)(UBound(e(1))) = 1
                x(n) = e
            End If
        Next
    End With
    For i = 1 To n
        x(i)(1) = SortA(x(i)(1))
    Next
    With Sheets.Add.Cells(1).Resize(, UBound(a, 2))
        .Value = a
        .Rows(2).Resize(n).Value = Application.Index(x, 0, 0)
        .CurrentRegion.Columns.AutoFit
    End With
End Sub

Sub VSortM(ary, LB, UB, ref)
    Dim i As Long, ii As Long, iii As Long, m, temp
    i = UB: ii = LB
    m = ary(Int((LB + UB) / 2), ref)
    Do While ii <= i
        Do While ary(ii, ref) > m: ii = ii + 1: Loop
        Do While ary(i, ref) < m: i = i - 1: Loop
        If ii <= i Then
            For iii = LBound(ary, 2) To UBound(ary, 2)
                temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp
            Next
            i = i - 1: ii = ii + 1
        End If
    Loop
    If LB < i Then VSortM ary, LB, i, ref
    If ii < UB Then VSortM ary, ii, UB, ref
End Sub

Function SortA(ByVal txt As String) As String
    Dim x, y, i As Long, ii As Long, m As Object, temp
    x = Split(txt, ",")
    If UBound(x) > 0 Then
        ReDim y(UBound(x))
        With CreateObject("VBScript.RegExp")
            .Global = True
            .Pattern = "\d+"
            For i = 0 To UBound(x)
                y(i) = Trim$(x(i))
                If .test(y(i)) Then
                    For ii = .Execute(y(i)).Count - 1 To 0 Step -1
                        Set m = .Execute(y(i))(ii)
                        y(i) = Application.Replace(y(i), m.firstindex + 1, _
                               m.Length, Format$(m, String(12, "0")))
                    Next
                End If
            Next
        End With
        For i = 0 To UBound(x)
            For ii = i + 1 To UBound(x)
                If y(i) > y(ii) Then
                    temp = y(i): y(i) = y(ii): y(ii) = temp
                    temp = x(i): x(i) = x(ii): x(ii) = temp
                End If
        Next ii, i
    End If
    SortA = Join(x, ",")
End Function

Ok Richard sir..

CutOff all the way...

Sub test()
    Dim a, e, i As Long, ii As Long, txt As String, temp, w, x(), n As Long
    With Sheets("sheet1")
        With Intersect(.Columns("b:o"), .UsedRange)
            a = Application.Index(.Value, Evaluate("row(1:" & _
            .Rows.Count & ")"), [{1,3,4,9,14,10,11,14}])
            a(1, 1) = a(1, 1) & " Grouping"
            a(1, 8) = "No. of Column/Wall"
        End With
    End With
    VSortM a, 2, UBound(a, 1), 5
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If a(i, 1) <> "" Then
                For Each e In Array(2, 3)
                    txt = txt & Chr(2) & a(i, e)
                Next
                If IsEmpty(.Item(txt)) Then
                    ReDim w(1 To 1)
                Else
                    w = .Item(txt)
                    ReDim Preserve w(1 To UBound(w) + 1)
                End If
                w(UBound(w)) = Application.Index(a, i, 0)
                .Item(txt) = w
            End If
            txt = ""
        Next
        For Each e In .items
            If UBound(e) > 1 Then
                n = n + 1: ReDim Preserve x(1 To n): x(n) = e(1)
                temp = e(1)(UBound(e(1))) * 0.87
                CutOff e, x, n, 2, temp
            Else
                n = n + 1: ReDim Preserve x(1 To n)
                e(1)(UBound(e(1))) = 1
                x(n) = e
            End If
        Next
    End With
    With Sheets.Add.Cells(1).Resize(, UBound(a, 2))
        .Value = a
        .Rows(2).Resize(n).Value = Application.Index(x, 0, 0)
        .CurrentRegion.Columns.AutoFit
    End With
End Sub

Private Sub CutOff(e, x, n As Long, ref, temp)
    Dim i As Long, y
    y = x(n)
    If ref > UBound(e) Then
         y(UBound(y)) = UBound(Split(y(1), ",")) + 1
         x(n) = y
    Else
        For i = ref To UBound(e)
            If e(i)(UBound(e(i))) >= temp Then
                y(1) = y(1) & "," & e(i)(1)
            Else
                y(UBound(y)) = UBound(Split(y(1), ",")) + 1
                y(1) = SortA(y(1)): x(n) = y
                n = n + 1: ReDim Preserve x(1 To n): x(n) = e(i)
                temp = e(i)(UBound(e(i))) * 0.87
                CutOff e, x, n, i + 1, temp
            End If
        Next
        y(UBound(y)) = UBound(Split(y(1), ",")) + 1
        y(1) = SortA(y(1)): x(n) = y
    End If
End Sub

Sub VSortM(ary, LB, UB, ref)
    Dim i As Long, ii As Long, iii As Long, m, temp
    i = UB: ii = LB
    m = ary(Int((LB + UB) / 2), ref)
    Do While ii <= i
        Do While ary(ii, ref) > m: ii = ii + 1: Loop
        Do While ary(i, ref) < m: i = i - 1: Loop
        If ii <= i Then
            For iii = LBound(ary, 2) To UBound(ary, 2)
                temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp
            Next
            i = i - 1: ii = ii + 1
        End If
    Loop
    If LB < i Then VSortM ary, LB, i, ref
    If ii < UB Then VSortM ary, ii, UB, ref
End Sub

Function SortA(ByVal txt As String) As String
    Dim x, y, i As Long, ii As Long, m As Object, temp
    x = Split(txt, ",")
    If UBound(x) > 0 Then
        ReDim y(UBound(x))
        With CreateObject("VBScript.RegExp")
            .Global = True
            .Pattern = "\d+"
            For i = 0 To UBound(x)
                y(i) = Trim$(x(i))
                If .test(y(i)) Then
                    For ii = .Execute(y(i)).Count - 1 To 0 Step -1
                        Set m = .Execute(y(i))(ii)
                        y(i) = Application.Replace(y(i), m.firstindex + 1, _
                               m.Length, Format$(m, String(12, "0")))
                    Next
                End If
            Next
        End With
        For i = 0 To UBound(x)
            For ii = i + 1 To UBound(x)
                If y(i) > y(ii) Then
                    temp = y(i): y(i) = y(ii): y(ii) = temp
                    temp = x(i): x(i) = x(ii): x(ii) = temp
                End If
        Next ii, i
    End If
    SortA = Join(x, ",")
End Function

sir Total no. of items are 30. but after grouping showing 51. some items are repeated at groups. before and after grouping items total should be same.

Thank you..

Replace "CutOff" sub routine with below.

Private Sub CutOff(e, x, n As Long, ref, temp)
    Dim i As Long, y
    y = x(n)
    For i = ref To UBound(e)
        If e(i)(UBound(e(i))) >= temp Then
            y(1) = y(1) & "," & e(i)(1)
        Else
            Exit For
        End If
    Next
    y(UBound(y)) = UBound(Split(y(1), ",")) + 1
    y(1) = SortA(y(1)): x(n) = y
    If i <= UBound(e) Then
        n = n + 1: ReDim Preserve x(1 To n): x(n) = e(i)
        temp = e(i)(UBound(e(i))) * 0.87
        CutOff e, x, n, i + 1, temp
    End If
End Sub

sir, excellent... sir can i ask the reason why it was not working when already other macro present in my excel file or paste it to other file showing error like this image?

Thank you..

No idea.....

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.

Thank you Sir..

Sir, small error observed at arranging grouping. that is not a major...by size after 300 600, next bigger item is 230 600 after this 230 450.
this is only the correction..everything is perfect.

Thank you..

Replace "test" sub procedure with the below.

Sub test()
    Dim a, e, i As Long, ii As Long, txt As String, temp, w, x(), n As Long
    With Sheets("sheet1")
        With .Range("b1", .Range("b" & .Rows.Count).End(xlUp)).Resize(, 14)
            a = Application.Index(.Value, Evaluate("row(1:" & _
            .Rows.Count & ")"), [{1,3,4,9,14,10,11,14}])
            a(1, 1) = a(1, 1) & " Grouping"
            a(1, 8) = "No. of Column/Wall"
        End With
    End With
    ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
    For i = 2 To UBound(a, 1)
        a(i, UBound(a, 2)) = Join(Array(Format$(a(i, 2), "00000.0000"), _
        Format$(a(i, 3), "00000.0000"), Format$(a(i, 5), "00000.0000")))
    Next
    VSortM a, 2, UBound(a, 1), UBound(a, 2)
    ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If a(i, 1) <> "" Then
                For Each e In Array(2, 3)
                    txt = txt & Chr(2) & a(i, e)
                Next
                If IsEmpty(.Item(txt)) Then
                    ReDim w(1 To 1)
                Else
                    w = .Item(txt)
                    ReDim Preserve w(1 To UBound(w) + 1)
                End If
                w(UBound(w)) = Application.Index(a, i, 0)
                .Item(txt) = w
            End If
            txt = ""
        Next
        For Each e In .items
            If UBound(e) > 1 Then
                n = n + 1: ReDim Preserve x(1 To n): x(n) = e(1)
                temp = e(1)(UBound(e(1))) * 0.87
                CutOff e, x, n, 2, temp
            Else
                n = n + 1: ReDim Preserve x(1 To n)
                e(1)(UBound(e(1))) = 1
                x(n) = e
            End If
        Next
    End With
    With Sheets.Add.Cells(1).Resize(, UBound(a, 2))
        .Value = a
        .Rows(2).Resize(n).Value = Application.Index(x, 0, 0)
        .CurrentRegion.Columns.AutoFit
    End With
End Sub

Hi Kaper sir,
sorry for re open this thread...may i ask for final file.. i have 2nd type of sheet. comparing to 1st type no of loops are very less. in this Grouping
by Maxium of "PComb" values. this is at "F" column in my sample file. so sort out group by Maximum "Pcomb Value" with upto 0.87 factor
cutoff. for example my maximum PComb value is "1728.83". so cut off up to 1728.83*0.87 = 1504.08. so search value
from 1728.83 to 1504.08 and group them as "1". remaining procedure is same for groups 1,2,3,4,5.

please edit as per this file which is you prepared at post #6.

Thank you..