Posts by MickG

Sub DelDupAdd()
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, Txt As String, nRng As Range
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
    With Application
        Txt = Join(.Transpose(.Transpose(Dn.Resize(, 4))), ",")
    End With
    If Not Dic.Exists(Txt) Then
        Dic.Add Txt, Dn
    Else
        Dic(Txt).Offset(, 4).Value = Dic(Txt).Offset(, 4).Value + Dn.Offset(, 4).Value
         If nRng Is Nothing Then Set nRng = Dn Else Set nRng = Union(nRng, Dn)
    End If
Next
If Not nRng Is Nothing Then nRng.EntireRow.Delete
End Sub

Sub MG30Jul56
Dim Rng As Range, Dn As Range, n As Long, txt As String, Ray() As Variant, Ac As Long
Dim Current As Variant, Previous As Variant, c As Long, r As Long, Var1 As Variant, Var2 As Variant
Current = Sheets("2_Current").Cells(5, 2).CurrentRegion
Previous = Sheets("1_Previous").Cells(5, 2).CurrentRegion
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
For r = 1 To 2
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
    If r = 1 Then
        Var1 = Current: Var2 = Previous
    Else
        Var1 = Previous: Var2 = Current
    End If
    For n = 5 To UBound(Var1, 1)
           ' This is for entire row if required
           ' Join(Application.Index(Var1, n, 0), ",")
            txt = Var1(n, 1) & Var1(n, 2) & Var1(n, 3)
         .Item(txt) = Empty
    Next n
    For n = 5 To UBound(Var2, 1)
        ' This is for entire row if required
        'txt = Join(Application.Index(Var2, n, 0), ",")
        txt = Var2(n, 1) & Var2(n, 2) & Var2(n, 3)
            If Not .exists(txt) Then
                c = c + 1
                ReDim Preserve Ray(1 To UBound(Var2, 2), 1 To c)
                For Ac = 1 To UBound(Var2, 2)
                    Ray(Ac, c) = Var2(n, Ac)
                Next Ac
            End If
    Next n
If r = 1 Then
With Sheets("3_Dropped").Range("B5").Resize(c, UBound(Previous, 2))
   .Parent.Range("B5").Resize(200, 100).ClearContents
   .Value = Application.Transpose(Ray)
   .Sort key1:=.Parent.Range("C5"), order1:=xlAscending, Header:=xlNo
End With
Erase Ray: c = 0
Else
With Sheets("4_new").Range("B5").Resize(c, UBound(Previous, 2))
   .Parent.Range("B5").Resize(200, 100).ClearContents
   .Value = Application.Transpose(Ray)
   .Sort key1:=.Parent.Range("C5"), order1:=xlAscending, Header:=xlNo
End With
End If
End With
Next r
End Sub

Sub nSum()
Dim Rng As Range, Dn As Range, n As Long, Txt As String, Ac As Long
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count, 1 To 5)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    Txt = Join(Application.Transpose(Application.Transpose(Dn.Resize(, 4))), ",")
    If Not .Exists(Txt) Then
        n = n + 1
        For Ac = 1 To 5: ray(n, Ac) = Dn.Offset(, Ac - 1): Next Ac
        .Add Txt, n
    Else
       ray(.Item(Txt), 5) = ray(.Item(Txt), 5) + Dn.Offset(, 4)
    End If
Next
n = .Count
End With
With Sheets("Sheet2").Range("A1").Resize(n, 5)
    .Value = ray
    .Borders.Weight = 2
    .Columns.AutoFit
End With
End Sub

Private Sub CommandButton1_Click()
    Dim rParents As Range, rNode As Range, rOut As Range
    Dim lRow As Long
     
    Set dic = CreateObject("scripting.dictionary")
    Set rParents = Range("A2", Range("A2").End(xlDown))
    Set rOut = Range("D2")
     
    For Each rNode In rParents
        If Not dic.Exists(rNode.Value) Then dic.Add rNode.Value, New Collection
        dic(rNode.Value).Add (rNode.Offset(, 1).Value)
    Next rNode
    Call DisplayTree("TableZ.Main", dic, rOut, lRow, 0)
End Sub
 
 ' Display the tree
Sub DisplayTree(ByVal sParent As String, dic, rOut As Range, _
    ByRef lRow As Long, ByVal lLevel As Long)
     
     
    Dim vChild
    If lLevel + lRow = 0 Then rOut = sParent
    For Each vChild In dic(sParent)
        lRow = lRow + 1
        rOut(lRow, lLevel + 2) = vChild
        If dic.Exists(vChild) Then
            lRow = lRow - 1 '<-----I added this
            Call DisplayTree(vChild, dic, rOut, lRow, lLevel + 1)
        End If
    Next vChild
End Sub

Sub ALeave()
Dim Rng As Range, Dn As Range, n As Long, Cb As Range, Dt As Date
Dim Dic As Object, Msg As String, CbRng As Range, nStr As String, Sp As Variant
Set Dic = CreateObject("scripting.dictionary")
 Dic.CompareMode = vbTextCompare
    Set CbRng = Range("AS8:AS11")
    
For Each Cb In CbRng
    If Cb Then
        nStr = nStr & IIf(nStr = "", Cb.Offset(, 1).Value, ", " & Cb.Offset(, 1).Value)
    End If
Next Cb
Sp = Split(nStr, ", ")
 Set Rng = Range("B7:B12")
     Rng.Offset(, 3).Interior.Color = 49407
If UBound(Sp) > 0 Then
     For n = 0 To UBound(Sp)
        For Each Dn In Rng
            If Dn.Value = Sp(n) Then
               For Dt = Dn.Offset(, 1).Value To Dn.Offset(, 2).Value
                    If Not Dic.Exists(Dt) Then
                        Dic.Add Dt, Dn
                    Else
                       Set Dic(Dt) = Union(Dic(Dt), Dn)
                       Dic(Dt).Offset(, 3).Interior.Color = vbRed
                    End If
               Next Dt
            End If
        Next Dn
    Next n
End If
Dim K As Variant, Temp As String, nRng As Range, R As Range
For Each K In Dic.keys
 If Dic(K).Count > 1 Then
     If nRng Is Nothing Then Set nRng = Dic(K) Else Set nRng = Union(nRng, Dic(K))
 End If
Next K
If Not nRng Is Nothing Then
    For Each R In nRng
        Msg = Msg & "Overlap Dates" & vbLf & R.Value & " From:- " & R.Offset(, 1).Value & " To " & R.Offset(, 2).Value & vbLf
    Next R
    MsgBox Msg
Else
    MsgBox "No overlap Dates Between " & nStr
End If
End Sub

Option Explicit
Private Sub UserForm_Initialize()
ListBox1.ColumnCount = 2
'Change range to suit !!!
ListBox1.List = Range("A1:B15").Value
ListBox1.MultiSelect = fmMultiSelectSingle
End Sub


Private Sub ListBox1_Click()
Dim n As Long
 With ListBox1
  For n = 0 To .ListCount - 1
  If .Selected(n) Then
   .List(n, 1) = IIf(.List(n, 1) = "x", "", "x")
 End If
 Next n
 End With
End Sub

Sub Trans()
Dim Ray As Variant, c As Long, n As Long, ac As Long
Ray = Range("B5").CurrentRegion
ReDim nRay(1 To UBound(Ray, 1) * (UBound(Ray, 2) - 3), 1 To 5)
 nRay(1, 1) = "Project No": nRay(1, 2) = "Code": nRay(1, 3) = "Employee Name"
 nRay(1, 4) = "Week Ending": nRay(1, 5) = "Hours"
 c = 1
 For n = 2 To UBound(Ray, 1)
    For ac = 4 To UBound(Ray, 2)
        c = c + 1
        nRay(c, 1) = Ray(n, 1): nRay(c, 2) = Ray(n, 2): nRay(c, 3) = Ray(n, 3)
        nRay(c, 4) = Ray(1, ac): nRay(c, 5) = Ray(n, ac)
    Next ac
 Next n
With Sheets("Sheet2").Range("A1").Resize(c, 5)
    .Value = nRay
    .Borders.Weight = 2
    .Columns.AutoFit
End With
End Sub