Posts by MickG

Sub Combinations()
'Ref PCG
Dim rRng As Range, p
Dim vElements, lRow As Long, vresult As Variant
 Set rRng = Range("A1", Range("A1").End(xlDown))
p = 3
vElements = Application.Index(Application.Transpose(rRng), 1, 0)
ReDim vresult(1 To p)
Call CombinationsNP(vElements, CInt(p), vresult, lRow, 1, 1)
End Sub
 
Sub CombinationsNP(vElements As Variant, p As Integer, vresult As Variant, lRow As Long, iElement As Integer, iIndex As Integer)
Dim i As Integer
For i = iElement To UBound(vElements)
    vresult(iIndex) = vElements(i)
    If iIndex = p Then
        lRow = lRow + 1
        Range("B" & lRow) = Join(vresult, ", ")
        'Range("C" & lRow).Resize(, p) = vresult'Multi column Result
    Else
        Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1)
    End If
Next i
End Sub

Sub Mstr()
Dim Rng As Range, Dn As Range, n As Long
Dim Dic As Object, col As Long, mRng As Range
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
With Sheets("Master").Range("A2")
    .Value = "1"
    .AutoFill Destination:=.Resize(Rng(Rng.Count)), Type:=xlFillSeries
    With .Parent
        Set mRng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
        col = .Range("A1").CurrentRegion.Columns.Count
        .Cells(1, col + 1).Value = "Week " & col
    End With
End With
Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    For Each Dn In Rng: Dic(Dn.Value) = Dn.Offset(, 1).Value: Next
        For Each Dn In mRng
            If Dic.exists(Dn.Value) Then
                Dn.Offset(, col) = Dic(Dn.Value)
            End If
    Next Dn
End Sub

'Code1
Private Sub CommandButton1_Click()
Dim Rng As Range, Dn As Range
Set Rng = Range("K2:K75")
For Each Dn In Rng
    With Dn.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:="Tick,Cross,N/A"
    End With
Next Dn
End Sub




'Code2
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range
Set Rng = Range("K2:K75")
Application.EnableEvents = False
If Target.Count = 1 Then
    If Not Intersect(Target, Rng) Is Nothing Then
        Select Case Target
            Case "Tick": Target.Value = ChrW(10004): Target.Font.Name = "Calibra(Body)"
            Case "Cross": Target = ChrW(10008): Target.Font.Name = "Calibra(Body)"
            Case "N/A": Target.Font.Name = "Calibra(body)"
        End Select
    End If
End If
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim RngA As Range, Dn As Range, Col As Long
    Dim RngG As Range, Rng As Range
    Application.EnableEvents = False
    If Target.Column = 1 Or Target.Column = 7 Then
        Set RngA = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
        Set RngG = Range(Range("G1"), Range("G" & Rows.Count).End(xlUp))
        Set Rng = Union(RngA, RngG)
        For Each Dn In Rng
            If UCase(Dn.Value) = UCase(Target.Value) And Not Dn.Address = Target.Address Then
                MsgBox "Invalid Entry"
                Target.Value = ""
            End If
        Next
    End If
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range, Col As Long
Application.EnableEvents = False
If Target.Column = 1 Or Target.Column = 7 Then
Col = IIf(Target.Column = 1, 7, 1)
Set Rng = Range(Cells(1, Col), Cells(Rows.Count, Col).End(xlUp))
    For Each Dn In Rng
        If Dn.Value = Target.Value Then
            MsgBox "Invalid Entry"
            Target.Value = ""
        End If
        Next
End If
Application.EnableEvents = True
End Sub

Sub Rep()
Dim Ray As Variant, Ray2 As Variant, n As Long
Ray = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 1)
Ray2 = Sheets("Sheet2").Range("A2").CurrentRegion.Resize(, 1)
With CreateObject("scripting.dictionary")
 .CompareMode = vbTextCompare
For n = 1 To UBound(Ray2, 1)
    .Item(Ray2(n, 1)) = Empty
Next
For n = 2 To UBound(Ray, 1)
    If .exists(Trim(Split(Ray(n, 1), "-")(1))) Then
        Ray(n, 1) = Trim(Split(Ray(n, 1), "-")(0))
    End If
 Next n
End With
Sheets("Sheet1").Range("A1").Resize(UBound(Ray, 1)) = Ray
End Sub

Sub cCols()
Dim Rng As Range, Dn As Range, R As Long, G As Long, Y As Long
Set Rng = Range(Range("N39"), Range("N" & Rows.Count).End(xlUp))
For Each Dn In Rng
If Not temp = Dn.MergeArea.Address Then
    Select Case Dn.DisplayFormat.Interior.Color
        Case 255: R = R + 1
        Case 5296274: G = G + 1
        Case 65535: Y = Y + 1
    End Select
End If
temp = Dn.MergeArea.Address
Next Dn
With Sheets("Dash Board")
    .Range("D7").Value = R
    .Range("D8").Value = Y
    .Range("D9").Value = G
End With
End Sub

Sub Data()
Dim Rng As Range, Dn As Range, Data As Range
Set Data = Sheets("Data").Range("A1").CurrentRegion
Set Data = Data.Offset(1, 1).Resize(Data.Rows.Count - 1, Data.Columns.Count - 1)
    With Sheets("LOCATIONS")
        Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
    End With
    With Sheets("RESULT")
        c = 2
        For Each Dn In Rng
            Range("A" & c).Resize(Data.Rows.Count) = Dn
            Range("B" & c).Resize(Data.Rows.Count, Data.Columns.Count).Value = Data.Value
            c = c + Data.Rows.Count
        Next Dn
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
 'Another workaround Placing dummy ("$A$1")value in array, to Make minimum of 2 values, on entry of first date.
 'This should enable the first and subsequent dates to be processed. !!!
    Dim Dn As Range, nR As Range, c As Long, p As Long
    Dim ray As Variant, Rng As Range, Q As Variant
    Dim Dic As Object, nDic As Object
    Dim n As Long 'Date######
    Dim R As Range, Dt As Date
    Dim nCol As Integer
    Dim rCols As Variant, col As Variant, K As Variant
    If Not Intersect(Target, Range("A:B,K:L,U:S")) Is Nothing Then
        rCols = Array("A", "K", "U")
        Set Dic = CreateObject("Scripting.Dictionary")
        Dic.CompareMode = 1
        Set nDic = CreateObject("Scripting.Dictionary")
        nDic.CompareMode = 1
         
       nCol = 2
       For Each col In rCols
            Set Rng = Range(Range(col & "1"), Range(col & Rows.Count).End(xlUp))
            Rng.Interior.ColorIndex = xlNone
            For Each Dn In Rng.Areas
                For Each R In Dn
                    If IsDate(R) Then
                        Set nR = IIf(R.Offset(, 1) = "", R, R.Offset(, 1))
                        For Dt = R To nR
                            If Not Dic.Exists(Dt) Then
                                Dic.Add Dt, R
                            Else
                                Set Dic(Dt) = Union(Dic(Dt), R)
                            End If
                        Next Dt
                    End If
                Next R
            Next Dn
        Next col
         
        For Each K In Dic.keys
           ' MsgBox nDic(Dic(K).Address)
           If Dic.Item(K).Count > 1 Then
             
                nDic(Dic(K).Address) = Empty
            Else
            nDic("$A$1") = Empty
            End If
        Next K
        
        If nDic.Count > 1 Then
        ray = Application.Transpose(nDic.keys)
        ReDim nray(1 To UBound(ray, 1) + 1, 1 To 2) As Range
        c = 0
        For n = 1 To UBound(ray, 1)
            If Not ray(n, 1) = "" Then
                c = c + 1
                For p = n To UBound(ray, 1)
                    If Not ray(p, 1) = "" Then
                        If nray(c, 1) Is Nothing Then
                            Set nray(c, 1) = Range(ray(p, 1))
                            ray(n, 1) = ""
                        ElseIf Not Intersect(nray(c, 1), Range(ray(p, 1))) Is Nothing Then
                            Set nray(c, 1) = Union(nray(c, 1), Range(ray(p, 1)))
                            ray(p, 1) = ""
                        End If
                    End If
                Next p
            End If
        Next n
        For n = 1 To c
            nCol = nCol + 1
            nCol = IIf(nCol = 13, 3, nCol)
            If Not nray(n, 1).Address = "$A$1" Then nray(n, 1).Interior.ColorIndex = nCol
        Next n
    End If
End If
End Sub