Sub CombineCluster()
Dim Rng As Range
Dim Dn As Range
Dim nRng As Range
Dim Tri As String
Dim Q As Variant
Dim k
Dim Rw As Integer
Dim Txt As String
Dim Ray(1 To 4)
Dim Fd As Boolean
Dim n As Integer
Dim Del As String
Dim Title As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set Rng = Range(Range("C7"), Range("C" & Rows.count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
'If Not IsNumeric(Right(Dn, 1)) Then
' Dn = Left(Dn, Len(Dn) - 1)
'End If
Tri = Dn & Dn.Offset(, 1)
If Dn.Offset(, 12) = 4 Then
If Not .Exists(Tri) Then
Set Ray(Dn.Offset(, 11)) = Dn
.Add Tri, Ray
Else
Q = .Item(Tri)
Set Q(Dn.Offset(, 11)) = Dn
.Item(Tri) = Q
End If
End If
Next
For Each k In .Keys
For n = 1 To UBound(Ray)
If IsEmpty(.Item(k)(n)) Then
Fd = True
End If
Next n
If Fd = False Then
If .Item(k)(1).Offset(, 7) = .Item(k)(2).Offset(, 7) And _
.Item(k)(1).Offset(, 8) = .Item(k)(2).Offset(, 8) And _
.Item(k)(3).Offset(, 7) = .Item(k)(4).Offset(, 7) And _
.Item(k)(3).Offset(, 8) = .Item(k)(4).Offset(, 8) Then
For Rw = 1 To UBound(.Item(k))
Del = IIf(Rw = 2, Chr(10), "")
Title = "Mc WON Flavour %"
Txt = Txt & Join(Application.Index(.Item(k)(Rw).Resize(, 12).Value, , Array(1, 2, 7, 8, 9))) & Chr(10) & Del ''Change these numbers for the columns you want !!!
Next Rw
If MsgBox("Do you wish to combine the following?" & Chr(10) & Chr(10) & Title & Chr(10) & Txt, vbYesNo + vbQuestion, "Combine Runs") = vbYes Then
.Item(k)(1).Offset(, 5) = .Item(k)(1).Offset(, 5) + .Item(k)(2).Offset(, 5)
.Item(k)(3).Offset(, 5) = .Item(k)(3).Offset(, 5) + .Item(k)(4).Offset(, 5)
.Item(k)(1).Offset(, 9) = .Item(k)(1).Offset(, 9) + .Item(k)(2).Offset(, 9)
.Item(k)(3).Offset(, 9) = .Item(k)(3).Offset(, 9) + .Item(k)(4).Offset(, 9)
If nRng Is Nothing Then
Set nRng = Union(.Item(k)(2), .Item(k)(4))
Else
Set nRng = Union(nRng, .Item(k)(2), .Item(k)(4))
End If
End If
Txt = ""
End If
End If
Next k
If Not nRng Is Nothing Then
nRng.EntireRow.Delete
End If
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub CombineRest()
Dim Rng As Range
Dim Dn As Range
Dim nRng As Range
Dim Tri As String
Dim Q As Variant
Dim k
Dim Rw As Range
Dim nnRng As Range
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set Rng = Range(Range("C7"), Range("C" & Rows.count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
'If Not IsNumeric(Right(Dn, 1)) Then
' Dn = Left(Dn, Len(Dn) - 1)
'End If
Tri = Dn & Dn(, 5) & Dn(, 8) & Dn(, 9)
If Not .Exists(Tri) Then
.Add Tri, Array(Dn, nRng)
Else
Q = .Item(Tri)
If Q(1) Is Nothing Then
Set Q(1) = Dn
Else
Set Q(1) = Union(Q(1), Dn)
End If
.Item(Tri) = Q
End If
Next
For Each k In .Keys
If Not .Item(k)(1) Is Nothing And .Item(k)(0).Offset(, 12) <= 1 Then
Tx0 = "Mc Base Code %" & Chr(10) & Join(Application.Index(.Item(k)(0).Offset(, 0).Resize(, 15).Value, , Array(1, 5, 8, 9))) 'Change thes numbers for the columns you want !!!
For Each Rw In .Item(k)(1)
Txt = Join(Application.Index(Rw.Offset(, 0).Resize(, 15).Value, , Array(1, 5, 8, 9))) & Chr(10) ''Change thes numbers for the columns you want !!!
Next Rw
If MsgBox("Do you wish to combine the following?" & Chr(10) & Chr(10) & Tx0 & Chr(10) & Txt, vbYesNo + vbQuestion, "Combine Runs") = vbYes Then
.Item(k)(0).Offset(, 5) = .Item(k)(0).Offset(, 5) + Application.Sum(.Item(k)(1).Offset(, 5))
.Item(k)(0).Offset(, 9) = .Item(k)(0).Offset(, 9) + Application.Sum(.Item(k)(1).Offset(, 9))
.Item(k)(0).Offset(, 14) = .Item(k)(0).Offset(, 14) + Application.Sum(.Item(k)(1).Offset(, 14))
If nnRng Is Nothing Then
Set nnRng = .Item(k)(1)
Else
Set nnRng = Union(nnRng, .Item(k)(1))
End If
End If
End If
Txt = ""
Next k
If Not nnRng Is Nothing Then
nnRng.EntireRow.Delete
End If
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Sub CombineClusterSets()
Dim Rng As Range
Dim Dn As Range
Dim n As Long
Dim Cols As String
Dim nRng As Range
Dim Q As Variant
Dim Dic As Object
Dim Doc As Object
Dim k
Dim Dup
Dim Tri As String
Dim Frt As Range
Dim DelRng As Range
Dim Txt As String
Set Rng = Range(Range("C7"), Range("C" & Rows.count).End(xlUp))
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
Cols = Dn.Offset(, 1)
If Not Dic.Exists(Cols) Then
Dic.Add Cols, Array(Dn, Dn.Offset(, 6), Dn.Offset(, 7))
Else
Q = Dic.Item(Cols)
Set Q(0) = Union(Q(0), Dn)
Q(1) = Q(1) & Dn.Offset(, 6)
Q(2) = Q(2) & ", " & Dn.Offset(, 7)
Dic.Item(Cols) = Q
End If
Next
Set Doc = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each k In Dic.Keys
If Dic.Item(k)(0).count >= 3 Then
If Not Doc.Exists(Dic.Item(k)(1)) Then
Doc.Add Dic.Item(k)(1), Dic.Item(k)
Else
Q = Doc.Item(Dic.Item(k)(1))
If MsgBox("Combination Acceptable" & Chr(10) & """M/C No""" & Space(10) & """WON No""" & Chr(10) & Space(3) & Q(0)(1) & Space(15) & Q(0)(1, 2) & "/" & Dic.Item(k)(0)(1, 2), vbOKCancel + vbQuestion, "Accept/Reject") = vbOK Then
For n = 1 To Q(0).count
Q(0)(n, 6) = Q(0)(n, 6) + Dic.Item(k)(0)(n, 6)
Q(0)(n, 10) = Q(0)(n, 10) + Dic.Item(k)(0)(n, 10)
Next n
If DelRng Is Nothing Then
Set DelRng = Dic.Item(k)(0)
Else
Set DelRng = Union(DelRng, Dic.Item(k)(0))
End If
End If
End If
End If
Next k
If Not DelRng Is Nothing Then DelRng.EntireRow.Delete
End Sub