Posts by MickG

Sub Merge2()
Dim Rng As Range, Dn As Range, n As Integer, R As Range
    Dim k As Variant, nRng As Range, rSt As String
    Dim Dic As Object, col As Integer
    For n = 0 To 2
        If rSt = vbNullString Then
            Set Rng = Range(Range("A1"), Range("a" & Rows.Count).End(xlUp))
        Else
            Set Rng = Range(Mid(rSt, 2))
        End If
        Set Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
        For Each Dn In Rng.Areas
           For Each R In Dn
                col = IIf(n = 0, 0, 1)
                If Not Dic.exists(Dn.Address & R.Offset(, col).Value) Then
                    Dic.Add Dn.Address & R.Offset(, col).Value, R.Offset(, col)
                Else
                    Set Dic.Item(Dn.Address & R.Offset(, col).Value) = Union(Dic.Item(Dn.Address & R.Offset(, col).Value), R.Offset(, col))
                End If
            Next R
        Next Dn
        rSt = vbNullString
        Application.DisplayAlerts = False
        For Each k In Dic.keys
            If Dic.Item(k).Count > 1 Then
                With Dic.Item(k)
                    rSt = rSt & "," & .Address
                    .MergeCells = True
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                End With
            End If
        Next k
        Application.DisplayAlerts = True
    Next n
End Sub

Sub NewTrial()
Dim Rng As Range, Dn As Range, nRng As Range, R As Range
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare




Set Rng = Range(Range("T3"), Range("T" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    For Each Dn In Rng.Areas
        Set Dn = Dn.Resize(Dn.Count + 1)
        For Each R In Dn
           If Not .Exists(Abs(R.Value)) Then
                .Add Abs(R.Value), R
            Else
             If .Item(Abs(R.Value)) + R.Value = 0 Then
                   If nRng Is Nothing Then
                        Set nRng = Union(.Item(Abs(R.Value)), R)
                    Else
                        Set nRng = Union(nRng, .Item(Abs(R.Value)), R)
                    End If
            .RemoveAll
            End If
         End If
            If Not nRng Is Nothing Then
                If R.Value = 0 Then
                    Set nRng = Union(nRng, .Item(Abs(R.Value)), R)
                End If
            End If
    
    Next R
.RemoveAll
Next
If Not nRng Is Nothing Then nRng.EntireRow.Delete
End With
End Sub

Sub rcSequence()
Dim n As Long, c As Long, nn As Long, p As Long
Dim RayA As Variant, col, v As Integer, d As Integer
RayA = Sheets("Sheet2").Range("A1").CurrentRegion
ReDim Ray(1 To 17, 1 To 25)




With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
For n = 65 To 80: .Item(Chr(n)) = n - 64: Next n
    For n = 2 To UBound(RayA, 1)
        If .exists(RayA(n, 1)) Then
            Ray(.Item(RayA(n, 1)) + 1, 1) = RayA(n, 1)
            Ray(1, RayA(n, 2) + 1) = RayA(n, 2)
            Ray(.Item(RayA(n, 1)) + 1, RayA(n, 2) + 1) = RayA(n, 3)
        End If
  
        If (n - 1) Mod 384 = 0 Then
            nn = nn + 1
            Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Master " & nn
            ActiveSheet.Range("A1").Resize(17, 25).Value = Ray
            ActiveSheet.Range("A1").Resize(17, 25).Columns.AutoFit
            ReDim Ray(1 To 17, 1 To 25)
        End If
    Next n
End With
End Sub

Sub NewShts()
Dim n As Long, c As Long, nn As Long, p As Long
Dim RayA As Variant, col, v As Integer, d As Integer
RayA = Sheets("Sheet2").Range("A1").CurrentRegion
ReDim Ray(1 To 17, 1 To 25)
With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
For n = 65 To 80: .Item(Chr(n)) = n - 64: Next n
    For n = 2 To UBound(RayA, 1)
       col = IIf(RayA(n, 2) Mod 2 = 0, 12 - (RayA(n, 2) / 2) + RayA(n, 2), (RayA(n, 2) + 1) / 2)
        If .exists(RayA(n, 1)) Then
            Ray(.Item(RayA(n, 1)) + 1, 1) = RayA(n, 1)
            Ray(.Item(RayA(n, 1)) + 1, col + 1) = RayA(n, 3)
        End If
  
        If (n - 1) Mod 384 = 0 Then
           d = 12: c = 0: v = 0
           For p = 1 To 24
                If p Mod 2 = 0 Then
                    d = d + 1: c = d
                Else
                    v = v + 1: c = v
                End If
                 Ray(1, c + 1) = p
            Next p
            nn = nn + 1
            Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Master " & nn
            ActiveSheet.Range("A1").Resize(17, 25).Value = Ray
            ReDim Ray(1 To 17, 1 To 25)
        End If
    Next n
End With
End Sub

Sub nShts()
Dim n As Long, c As Long, nn As Long
Dim RayA As Variant
RayA = Sheets("Sheet2").Range("A1").CurrentRegion
ReDim ray(1 To 16, 1 To 25)
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
For n = 65 To 80: .Item(Chr(n)) = n - 64: Next n
    For n = 2 To UBound(RayA, 1)
        If .exists(RayA(n, 1)) Then
            ray(.Item(RayA(n, 1)), 1) = RayA(n, 1)
            ray(.Item(RayA(n, 1)), RayA(n, 2) + 1) = RayA(n, 3)
        End If
   
        If (n - 1) Mod 384 = 0 Then
            nn = nn + 1
            Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Master " & nn
            ActiveSheet.Range("A2").Resize(16, 25).Value = ray
            ReDim ray(1 To 16, 1 To 25)
        End If
    Next n
End With
End Sub

Sub Del()
Dim Rng As Range, Dn As Range, nRng As Range
    Set Rng = Range(Range("U3"), Range("U" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
    For Each Dn In Rng.Areas
        If Application.Sum(Dn.Offset(, -1)) = 0 Then
            If nRng Is Nothing Then
                Set nRng = Dn.Resize(Dn.Count + 2)
            Else
                Set nRng = Union(nRng, Dn.Resize(Dn.Count + 2))
            End If
        End If
    Next Dn
    If Not nRng Is Nothing Then nRng.EntireRow.Delete
End Sub

Sub Del()
Dim Rng As Range, Dn As Range, nRng As Range
Set Rng = Range(Range("U2"), Range("U" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 1)
For Each Dn In Rng.Areas
If Application.Sum(Dn.Offset(, -1)) = 0 Then
    If nRng Is Nothing Then
        Set nRng = Dn
    Else
    Set nRng = Union(nRng, Dn)
  End If
End If
Next Dn
If Not nRng Is Nothing Then nRng.EntireRow.Delete
End Sub

Sub cCat()
Dim Rng As Range, Dn As Range, n As Long
Dim oRes As String, R As Range, nRng As Range
Set Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 2)
For Each Dn In Rng.Areas
Set nRng = Nothing
For Each R In Dn
    If nRng Is Nothing Then
        Set nRng = R
    Else
        Set nRng = Union(nRng, R)
    End If
Next R
 nRng(nRng.Count).Offset(1) = Join(Application.Transpose(nRng), "/")
 'Remove the 2 lines below if you do not want to fill the Cells in columns "F & G" (Blank Rows).
 nRng(nRng.Count).Offset(1, 4) = nRng(1).Offset(, 4) & "  Total"
 nRng(nRng.Count).Offset(1, 5) = Format(Application.Sum(nRng.Offset(, 5)), "#,##0.00")
Next
End Sub