Posts by MickG

MickG · Jan 8th 2016

Re: Highlight date clashes in Annual leave between staff

The problem is the codes does not like to find only one value in an Array.
I have not found a complete solution, but by not allowing the code to run until there are at least two matching dates , the code (as below) will run.
I hope that works for you at the moment.

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    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
           If Dic.Item(K).Count > 1 Then
                nDic(Dic(K).Address) = 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)
            nray(n, 1).Interior.ColorIndex = nCol
        Next n
    End If
End If
End Sub

Display More

MickG · Jan 8th 2016

Re: Highlight date clashes in Annual leave between staff

Can you send file with code, that fails ???

MickG · Dec 24th 2015

Re: Search 4 columns for value, list row for all instances found

You're welcome

MickG · Dec 24th 2015

Re: Search 4 columns for value, list row for all instances found

Try this:-
Results sheet "Schedules", Start "A1"

Code

Sub Teams()
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, c As Long
Dim Ray As Variant, Rw As Long, Ac As Long, Nams As Variant, Sp As Variant
Ray = Sheets("MatchList").Range("A1").CurrentRegion
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Rw = 2 To UBound(Ray, 1)
    For Ac = 4 To 7
        If Not Dic.Exists(Ray(Rw, Ac)) Then
            Dic.Add Ray(Rw, Ac), Rw
        Else
            Dic(Ray(Rw, Ac)) = Dic(Ray(Rw, Ac)) & "," & Rw
        End If
    Next Ac
Next Rw
Nams = Sheets("TeamList").Range("A1").CurrentRegion.Resize(, 1)
ReDim nray(1 To UBound(Ray, 1) * UBound(Nams, 1), 1 To UBound(Ray, 2))
For Rw = 1 To UBound(Nams, 1)
   Sp = Split(Dic(Nams(Rw, 1)), ",")
    For n = 0 To UBound(Sp)
        c = c + IIf(n = 0, 2, 1)
        For Ac = 1 To UBound(Ray, 2)
            If n = 0 Then
            nray(c - 1, Ac) = IIf(Ac = 1, Nams(Rw, 1), Ray(1, Ac))
            End If
            nray(c, Ac) = IIf(Ac = 1, Format(Ray(Sp(n), Ac), "hh:mm:ss"), Ray(Sp(n), Ac))
        Next Ac
    Next n
c = c + 2
Next Rw
With Sheets("Schedules").Range("A1").Resize(c, UBound(Ray, 2))
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
End With
End Sub

Display More

MickG · Dec 20th 2015

Re: Change code, copy the ListBox selection in sheet range A: I

You're welcome

MickG · Dec 20th 2015

Re: Change code, copy the ListBox selection in sheet range A: I

Try:-

Code

Private Sub CommandButton1_Click()
Dim i As Long
Dim Ac As Integer, c As Long
 ReDim ary(1 To 9, 1 To 1)
With Me.ListBox1
    For i = 0 To .ListCount - 1
        If .Selected(i) Then
        For Ac = 1 To 9
            ary(Ac, UBound(ary, 2)) = .List(i, Ac - 1)
        Next Ac
        ReDim Preserve ary(1 To 9, 1 To UBound(ary, 2) + 1)
        End If
    Next
End With
Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(ary, 2), 9).Value _
= Application.Transpose(ary)




End Sub

Display More

MickG · Dec 6th 2015

Re: AutoFill data from list

Try your returned file "Sheets1 "Data" , Sheet2 Results.

MickG · Dec 5th 2015

Re: AutoFill data from list

With Your data in "Sheet1" then try this code for Results in "Sheet2", starting "A1".

Code

Sub Data()
Dim Rw As Long, Ac As Long, Ray As Variant, n As Long
Ray = Sheets("Sheet1").Range("D5").CurrentRegion
ReDim nRay(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 2)
n = 1
nRay(1, 1) = "Title": nRay(1, 2) = "Number"
For Ac = 2 To 31
    For Rw = 2 To UBound(Ray, 1)
        If Not IsEmpty(Ray(Rw, Ac)) Then
            n = n + 1
            nRay(n, 1) = Ray(1, Ac)
            nRay(n, 2) = Ray(Rw, Ac)
        End If
    Next Rw
Next Ac
With Sheets("Sheet2").Range("A1").Resize(n, 2)
    .Parent.Range("A:B").ClearContents
    .Value = nRay
End With
End Sub

Display More

Regards Mick

MickG · Nov 17th 2015

Re: Clear cells within range based on Userform Combobox selection

Perhaps this for dates:-

Code

Dim cell As Range
For Each cell In Range("A1:CK3000")
   If IsDate(cell) Then
        If MonthName(Month(cell.Value), True) = ComboBox1.Text Then
            cell.Clear
        End If
   End If
Next
Unload Me
ActiveSheet.Range("A1").Select

MickG · Nov 11th 2015

Re: ComboBox1 filling another ComboBox2 with correct information (like a filter!)

If your altering the combobox manually then that's a bit different.
Perhaps add the lines in Shown #######:-

Code

ReDim Ray(1 To Dic.Count + 1)
If Dic.exists(Val(cbZipCode.Value)) Then '#######
For Each G In Dic(Val(cbZipCode.Value))
    c = c + 1
    Ray(c) = G
Next G
End If '#############

MickG · Nov 11th 2015

Re: ComboBox1 filling another ComboBox2 with correct information (like a filter!)

Try this in your "Ftable" code module.

Code

Option Explicit
Dim Dic As Object
Private Sub cbZipCode_Change()
Dim G As Variant, c As Integer
ReDim Ray(1 To Dic.Count + 1)
For Each G In Dic(Val(cbZipCode.Value))
    c = c + 1
    Ray(c) = G
Next G
cbCity.List = Application.Transpose(Ray)
End Sub




Private Sub cbZipCode_GotFocus()
Dim Rng As Range, Dn As Range, n As Long
With Sheets("Data")
    Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With




Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not Dic.exists(Dn.Value) Then
        Dic.Add Dn.Value, Dn.Offset(, 1)
    Else
        Set Dic(Dn.Value) = Union(Dic(Dn.Value), Dn.Offset(, 1))
    End If
Next
Sheets("Ftable").cbZipCode.List = Application.Transpose(Dic.Keys)
Sheets("Ftable").cbCity.ListIndex = -1
End Sub

Display More

MickG · Oct 15th 2015

Re: Array not working

Seems some confusion with sheet name , but try:-

Code

With Sheets("Consolidate")
With .Range("A5:P5")
     .Value = Array("Phase", "Type", "Combinde Cost Code ", "Description", "Original Budget", _
        "Approved Owner Changes", "Revised Budget", "Current Projection", _
        "Variance", "Total Job Cost to Date", "Total Committed", "Committed Cost JTD", _
        "Committed Cost Remaining", "Non Commited Projection", _
        "Non committed Cost JTD", "Non Committed Cost Remaining")
         
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Font.Bold = True
    End With
End With

Display More

MickG · Sep 27th 2015

Re: Moving cell value from incorrect row from data opened from html

You're welcome

MickG · Sep 24th 2015

Re: Moving cell value from incorrect row from data opened from html

Try this:-
NB:- This code will re-arrange your data.

Code

Sub Srt()
Dim Rng As Range, Dn As Range
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
Application.ScreenUpdating = False
Range("F1:G1") = Array("Time", "Value")
For Each Dn In Rng.Areas
    Dn.Offset(, 6) = Dn.Offset(, 5)
    Dn.Offset(, 5) = Dn.Offset(1, 4)
    Dn.Offset(, 5).NumberFormat = "hh:mm AM/PM"
Next Dn
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Display More

MickG · Sep 23rd 2015

Re: Multiple rows to columns

You're welcome

MickG · Sep 21st 2015

Re: Multiple rows to columns

Based on Data in sheet1 , try this for results in sheet2

Code

Sub RtoC()
Dim Rng As Range, Dn As Range, n As Long, c As Long
Dim Ray As Variant, R As Range
Set Rng = Range(Range("A4"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
ReDim Ray(1 To Rng.Count + 1, 1 To Rng.Count + 1)
For Each Dn In Rng
    If Not IsEmpty(Dn.Value) Then
        If Not .Exists(Dn.Value) Then
            n = n + 1
            Ray(1, n) = Dn.Value
            .Add Dn.Value, n
        End If
    End If
Next
c = 1
Set Rng = Range("B:B").SpecialCells(xlCellTypeConstants)
For Each Dn In Rng.Areas
    c = c + 1
    For Each R In Dn
       Ray(c, .Item(R.Offset(, -1).Value)) = R.Value
    Next R
Next Dn
 
Sheets("Sheet2").Range("A1").Resize(c, .Count + 1) = Ray
End With


End Sub

Display More

MickG · Sep 3rd 2015

Re: Highlight date clashes in Annual leave between staff

You're welcome
The Irony of the code is that its written to find a number of conflicts, and highlight them in different colours, But as you now have an Automated version it should only ever be necessary to check if the active cell date is a duplicate, which can be corrected immediately, and the finding of duplicate becomes superfluous.
Never mind it was an interesting Thread to try and resolve, and has provided me with some background code.
Regrds Mick

MickG · Sep 3rd 2015

Re: Highlight date clashes in Annual leave between staff

Try this "Change _Event"
To Load code:-
Right click sheet Tab.
From shortcut Menu, select "View Code"
VbWindow appears , Paste code into this window.
Close Vbwindow.
Run code By adding dates in appropriate Ranges.

Code

Private Sub Worksheet_Change(ByVal Target As Range)
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 Date, 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
        If Dic.Item(K).Count > 1 Then
            nDic(Dic(K).Address) = Empty
        End If
    Next K
    Ray = Application.Transpose(nDic.keys)
    ReDim nray(1 To UBound(Ray, 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)
        nray(n, 1).Interior.ColorIndex = nCol
    Next n
End If
End Sub

Display More

MickG · Sep 3rd 2015

Re: Highlight date clashes in Annual leave between staff

It Appears to work on your data file , below :-

MickG · Sep 3rd 2015

Re: Highlight date clashes in Annual leave between staff

Try this:-

Code

Sub cDates_A()
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 Date, R As Range, Dt As Date
Dim nCol As Integer
Dim rCols As Variant, col As Variant, K As Variant
Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
Set nDic = CreateObject("Scripting.Dictionary")
    nDic.CompareMode = 1
rCols = Array("A", "K", "U")
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
 If Dic.Item(K).Count > 1 Then
    nDic(Dic(K).Address) = Empty
End If
Next K
Ray = Application.Transpose(nDic.keys)
ReDim nray(1 To UBound(Ray, 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)
    nray(n, 1).Interior.ColorIndex = nCol
Next n
End Sub

Display More