Macro for identifying distinct days from time stamp doesn't work

[Andy0311]

Hello,
I run a seat time report for 30 teachers which measures the time they spent online (distinct days).

[TABLE="width: 688"]
<colgroup><col><col><col><col><col></colgroup><tbody>[TR]
[TD]Teacher[/TD]
[TD]Course[/TD]
[TD]Date[/TD]
[TD]Time
(hh:mm)[/TD]
[TD]IP Address[/TD]
[/TR]
[TR]
[TD]Allison, Robert[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD] [/TD]
[TD]*Home Page/eMail/Forum[/TD]
[TD]10/1/2019 5:39 AM[/TD]
[TD]0:00[/TD]
[TD]71.72.124.152[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD]*Home Page/eMail/Forum[/TD]
[TD]10/1/2019 6:44 AM[/TD]
[TD]0:00[/TD]
[TD]71.72.124.152[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD]Math Integrated Math III (1-18)[/TD]
[TD]10/1/2019 6:44 AM[/TD]
[TD]0:03[/TD]
[TD]71.72.124.152[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD]*Home Page/eMail/Forum[/TD]
[TD]10/1/2019 6:47 AM[/TD]
[TD]0:00[/TD]
[TD]71.72.124.152[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD]Math Integrated Math III (1-18)[/TD]
[TD]10/1/2019 6:47 AM[/TD]
[TD]0:06[/TD]
[TD]71.72.124.152[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD]*Home Page/eMail/Forum[/TD]
[TD]10/1/2019 6:53 AM[/TD]
[TD]0:00[/TD]
[TD]71.72.124.152[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD]*Home Page/eMail/Forum[/TD]
[TD]10/1/2019 9:08 AM[/TD]
[TD]0:00[/TD]
[TD]71.72.124.152[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD]Math Integrated Math III (1-18)[/TD]
[TD]10/1/2019 9:08 AM[/TD]
[TD]0:00[/TD]
[TD]71.72.124.152[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD]*Home Page/eMail/Forum[/TD]
[TD]10/1/2019 9:08 AM[/TD]
[TD]0:01[/TD]
[TD]71.72.124.152[/TD]
[/TR]
[TR]
[TD] [/TD]
[TD]Math Integrated Math III (1-18)[/TD]
[TD]10/1/2019 9:09 AM[/TD]
[TD]0:00[/TD]
[TD]71.72.124.152[/TD]
[/TR]
</tbody>[/TABLE]

The date column is a time stamp and I first have to take that data and separate the data the Text to Column function. Then I can take the date column and use Remove Duplicates, leaving me the unique days the teacher was online. My problem is that it works correctly for some teachers and incorrectly for others. Each teacher report is in a separate tab in my workbook. I need to know what I did wrong to make this macro work at times and at not. Any help would be appreciated. Here's the macro code:

Sub DistinctDays()
'
' DistinctDays Macro
'


'
Columns("D:F").Select
Range("D3").Activate
Selection.UnMerge
Columns("B:H").EntireColumn.AutoFit
Range("D6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("A4").Select
Columns("J:J").ColumnWidth = 27.71
Range("J6").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.TextToColumns Destination:=Range("J6"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
ActiveSheet.Range("$J$6:$J$511").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("E:F").Select
Selection.Delete Shift:=xlToLeft
Columns("I:J").Select
Selection.Delete Shift:=xlToLeft
Range("H4").Select
ActiveCell.FormulaR1C1 = "=COUNTA(R[2]C:R[18]C)"
Range("H5").Select
End Sub

Thank you in advance.

Andy

 

[MARK858]

I would recommend that put it in your Google drive and put a link in the thread, if you sent it in an email then you would infringe forum rule 4 and then it would be down to a Moderator how they handle it.

 

[Andy0311]

I have the same concerns as BlakeSkate at the moment but just out of interest what happens if you run the code below on a copy of your actual data.

Sub DistinctDays2()
    Dim myrow As Long, arr, mycell

    Application.ScreenUpdating = False
    Columns("D:F").UnMerge
    Columns("B:H").EntireColumn.AutoFit

    Range("D6:D" & Range("D" & Rows.Count).End(xlUp).Row).Copy Range("J6")

    Columns("J:J").ColumnWidth = 27.71


    Range("J6:J" & Range("J" & Rows.Count).End(xlUp).Row).TextToColumns Destination:=Range("J6"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True

    
    myrow = Cells(Rows.Count, "J").End(xlUp).Row - 5
    arr = Range("J6").Resize(myrow)
    With CreateObject("scripting.dictionary")
        For Each mycell In arr
            mycell = Trim(mycell)
            If Not .Exists(mycell) Then
                .Add mycell, Empty
                arr(.Count, 1) = mycell
            End If
        Next mycell
        Range("J6").Resize(myrow).ClearContents
        Range("J6").Resize(.Count) = arr
    End With

    Columns("E:F").Delete Shift:=xlToLeft
    Columns("I:J").Delete Shift:=xlToLeft
    Range("H4").FormulaR1C1 = "=COUNTA(R[2]C:R[18]C)"

    Application.ScreenUpdating = True
End Sub

I will try it as soon as I can. And thanks for your help.

Andy

 

[DataBlake]

you can just post the link the workbook here on the forum
make sure to change sensitive data or break the link after a solution is found although to help other people with maybe a similar problem leaving the workbook live would be best.

 

[Andy0311]

I will try it as soon as I can. And thanks for your help.

Andy

Your code worked perfectly! Thanks so much for your help, Mark.

Andy

 

[Andy0311]

Where can I read about posting the link on the forum. Also, see the code Mark858 offered. I ran it and it worked perfectly. My issue seems resolved. Thanks again,


A

 

[MARK858]

See this link and look under "Share a link to the file" then just paste the link in the thread. Please note that this isn't the way the management of the board prefer. They prefer you to post usable screenshots in the thread, to do this see this link.
BlakeSkate is using the Mr Excel HTML maker in post number 3 if you want to see how it displays.

If you are on 32bit Excel then I recommend Excel Jeanie as that reproduces conditional formatting as well as normal formatting.

Happy you seem to have your problem resolved