Posts by MickG

Sub N()
Dim Lst As Long, n As Long, R
Lst = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For n = Lst To 1 Step -1
    With Range("A" & n)
        .EntireRow.Insert
        If Len(.Value / 2) >= 5 Then
            R = .Value / 2 - Val(Left(.Value / 2, 4))
            .Offset(, 1) = .Value / 2 + R
            .Offset(1, 1) = .Value / 2 - R
        Else
            .Offset(, 1) = .Value / 2: .Offset(1, 1) = .Value / 2
        End If
    End With
Next n
Application.ScreenUpdating = True
End Sub

Sub nDates()
Dim Rng As Range, nRng As Range, Dn As Range, Sp As Variant, Sp1 As Variant
Dim Dt As Date, Dy As String, Mth As String, Yr As String, c As Long
Dim R As Range, Temp As String
With Sheets("data")
    Set Rng = .Range(.Range("A5"), .Range("A" & Rows.Count).End(xlUp))
End With
For Each Dn In Rng
    If InStr(Dn.Value, "-") > 0 Then
        Sp = Split(Dn.Value, "-"): Sp1 = Split(Sp(0), ",")
        Dy = Trim(Split(Sp1(1), " ")(1)): Mth = Trim(Split(Sp1(1), " ")(2)): Yr = Trim(Sp1(UBound(Sp1)))
        Dt = Dy & " " & Mth & " " & Yr
    Else
        If Dt = Date Then
            If nRng Is Nothing Then
                Set nRng = Dn
            Else
                Set nRng = Union(nRng, Dn)
            End If
        End If
    End If
Next Dn




Set nRng = Union(nRng, nRng.Areas(nRng.Areas.Count).Offset(1))
ReDim ray(1 To nRng.Count, 1 To 2)




For Each Dn In nRng.Areas
    For Each R In Dn
        If InStr(R.Offset(, 5).Value, "Job") > 0 Then Temp = Split(R.Offset(, 5).Value, " ")(1)
            If Not InStr(R.Offset(, 5).Value, "Job") > 0 Then
                c = c + 1
                ray(c, 1) = Temp
                ray(c, 2) = R.Offset(, 5).Value
            End If
    Next R
Next Dn




With Range("I1").Resize(c, 2)
    .Value = ray
    .Columns.AutoFit
End With
End Sub

Sub Rep()
Dim Rng As Range, Dn As Range




'Rng set the first row of data as Range Object.
'NB:- as an Object the range will have "Properties & method"
'In this cae we are using its "Value" property
Set Rng = Range(Range("A1"), Cells(1, Columns.Count).End(xlToLeft))




'Create Dictionary
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare




'Loop through all Cells within the "Rng" Objects (that is all the data in row 1)
For Each Dn In Rng
 'Dn is also a range object and represents each value in thge Object "Rng", as you loop through the "Rng" (The First row).
 'Because we want the property "Value" of the Range object, we add ".Value" (The value property is the Default value, but always best to add it)
 
 'First Value found is "Dog". it is not already in the dictionary , so it is Added
    If Not .Exists(Dn.Value) Then
  'First Value "Dog" added
    .Add Dn.Value, 0 ' The 0 is the "item" (.item) of the Dictionary value "Dog"
    'and is the counter for How many Dogs" are found. Intially set to 0.




Else
   'The next Time "Dog" is found the code will pass to this point.
    'Now the item of "Dog" was 0 but as this is the second time it is found ,
    'we need to increase the count to "2"
    ' so as below the "1" is added  to the .item("Dog")(the Dn.value)
    .Item(Dn.Value) = .Item(Dn.Value) + 1
    
   'Now, this particular (Dn.value) is the second Item of "Dog" found and  can
   'be Concatenated the range object "Dn.value" with the new value of its ".item" "2"
   'So this now returns the value "Dog 2" to the second  value of "Dog" in the first row.
    Dn.Value = Dn.Value & " " & .Item(Dn.Value)
End If
Next
    'The preceeding account Happens for each Unique value found in Row 1.
    'You need to think of each Unique Value in the Dictionary and its ".item" (the count) as being
    'an individual Unique Value set within the dictionary with its own Individual Count.
End With
End Sub

Sub Rep()
Dim Rng As Range, Dn As Range
Set Rng = Range(Range("A1"), Cells(1, Columns.Count).End(xlToLeft))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not .Exists(Dn.Value) Then
    .Add Dn.Value, 0
Else
    .Item(Dn.Value) = .Item(Dn.Value) + 1
    Dn.Value = Dn.Value & " " & .Item(Dn.Value)
End If
Next
End With
End Sub

Sub nDates()
Dim Rw As Long, Dn As Range
Dim Rng As Range
Dim Dic As Object
Dim Q As Variant, oMax As Long
Dim k As Variant, ac As Long
Dim p As Variant, c As Long
   
  With Sheets("Sheet2")
    Set Rng = .Range(.Range("K3"), .Range("K" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    For Each Dn In Rng
            If Not Dic.exists(Dn.Value) Then
                Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            End If
            If Not Dic(Dn.Value).exists(Dn.Offset(, -10).Value) And Dn.Offset(, 26).Value > "" Then
                Dic(Dn.Value).Item(Dn.Offset(, -10).Value) = Dn.Offset(, 26).Value
            End If
    Next Dn
c = 1
ReDim Ray(1 To Rng.Count + 1, 1 To Rng.Count)
     Ray(1, 1) = "Operators Name"
    For Each k In Dic.Keys
        If Not IsEmpty(k) Then
            ac = 1: c = c + 1
            Ray(c, 1) = k
            For Each p In Dic(k)
                ac = ac + 1
                oMax = Application.Max(oMax, ac)
                Ray(1, ac) = p
                Ray(c, ac) = Format(Dic(k).Item(p), "0.00")
            Next p
    End If
Next k
With Sheets("Result").Range("A1").Resize(c, oMax)
    .Value = Ray
    .Columns.AutoFit
 End With

Function UnQ(rng As Range) As String
Dim Dn As Range, n As Long, Sp As Variant
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
For Each Dn In rng
    Sp = Split(Dn.Value, ",")
    For n = 0# To UBound(Sp)
        .Item(Sp(n)) = Empty
    Next n
Next Dn
UnQ = Join(.Keys, ",")
End With
End Function

Sub UnQ()
Dim Rng As Range, Dn As Range, n As Long, Sp As Variant
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    Sp = Split(Dn.Value, ",")
    For n = 0# To UBound(Sp)
        .Item(Sp(n)) = Empty
    Next n
Next Dn
Range("A5").Value = Join(.Keys, ",")
End With

Sub DataSort()
 Dim Dn As Range, txt As String, Rng As Range
    Dim Dic As Object, k As Variant, n As Long
    Dim p As Variant, c As Long
    Dim col1 As Integer, col2 As Integer, oSet As Long
     
  With Sheets("Master")
    Set Rng = .Range(.Range("A3"), .Range("A" & Rows.Count).End(xlUp))
  End With
    ReDim ray(1 To Rng.Count, 1 To 57)
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    For Each Dn In Rng
        With Application
        txt = Join(.Transpose(.Transpose(Dn.Resize(, 9))), ",")
        End With
        If Not Dic.exists(txt) Then
            Set Dic(txt) = CreateObject("Scripting.Dictionary")
        End If
         
        If Not Dic(txt).exists(Dn.Offset(, 9).Value) Then
            Dic(txt).Add (Dn.Offset(, 9).Value), Dn
        Else
            Set Dic(txt).Item(Dn.Offset(, 9).Value) = _
            Union(Dic(txt).Item(Dn.Offset(, 9).Value), Dn)
        End If
    Next Dn
     
    For Each k In Dic.Keys
        c = c + 1
        For Each p In Dic(k)
           oSet = 10
           For n = 1 To 9
            ray(c, n) = Dic(k).Item(p)(1, n)
          Next n
            For n = 11 To 34
              col1 = IIf(p = "A", oSet, oSet + 1)
              ray(c, col1) = Dic(k).Item(p)(1, n)
              oSet = oSet + 2
            Next n
        Next p
    Next k
    With Sheets("Results").Range("A4").Resize(c, 57)
        .Value = ray
        .Columns.AutoFit
    End With
End Sub

Sub DataSort()
Dim Dn As Range, txt As String, Rng As Range
Dim Dic As Object, k As Variant
Dim p As Variant, c As Long
Dim col1 As Integer, col2 As Integer




Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    ReDim Ray(1 To Rng.Count, 1 To 11)
      Set Dic = CreateObject("Scripting.Dictionary")
         Dic.CompareMode = 1
   For Each Dn In Rng
        txt = Dn & "," & Dn.Offset(, 1) & "," & Dn.Offset(, 3).Value & "," & Dn.Offset(, 4).Value & "," & Dn.Offset(, 5).Value
        If Not Dic.exists(txt) Then
                Set Dic(txt) = CreateObject("Scripting.Dictionary")
            End If
        
        If Not Dic(txt).exists(Dn.Offset(, 2).Value) Then
                Dic(txt).Add (Dn.Offset(, 2).Value), Dn
        Else
                Set Dic(txt).Item(Dn.Offset(, 2).Value) = _
                Union(Dic(txt).Item(Dn.Offset(, 2).Value), Dn)
        End If
    Next Dn
  
    c = 2
    Ray(1, 1) = "Date": Ray(1, 2) = "M/C No": Ray(1, 3) = "PO.No": Ray(1, 4) = "Drg No"
    Ray(1, 5) = "Drg Name": Ray(1, 6) = "OPERATOR NAME": Ray(1, 8) = "M/C Time": Ray(1, 9) = "L/UL Time": Ray(1, 10) = "production"
    Ray(2, 6) = "A": Ray(2, 7) = "B": Ray(2, 8) = "Mint.": Ray(2, 9) = "Mint.": Ray(2, 10) = "Shift A": Ray(2, 11) = "Shift B"




    
    For Each k In Dic.Keys
       c = c + 1
       For Each p In Dic(k)
                Ray(c, 1) = Dic(k).Item(p)
                Ray(c, 2) = Dic(k).Item(p).Offset(, 1).Value
                Ray(c, 3) = Dic(k).Item(p).Offset(, 3).Value
                Ray(c, 4) = Dic(k).Item(p).Offset(, 4).Value
                Ray(c, 5) = Dic(k).Item(p).Offset(, 5).Value
                col1 = IIf(p = "A", 6, 7)
                Ray(c, col1) = Dic(k).Item(p).Offset(, 7).Value
                Ray(c, 8) = Dic(k).Item(p).Offset(, 8).Value
                Ray(c, 9) = Dic(k).Item(p).Offset(, 9).Value
                col2 = IIf(p = "A", 10, 11)
                Ray(c, col2) = Dic(k).Item(p).Offset(, 10).Value
        Next p
    Next k
With Sheets("Sheet2").Range("A1").Resize(c, 11)
     .Value = Ray
     .Columns.AutoFit
    .Range("F1:G1").MergeCells = True
    .Range("F1").HorizontalAlignment = xlCenter
    .Range("J1:K1").MergeCells = True
    .Range("J1").HorizontalAlignment = xlCenter
End With
End Sub