Excel VBA to find date string, add hour, and convert to mm/dd/yyyy

[simmerer]

Hello,
It looks like the server missed an update when the time changed to PDT. In the database some records have a time date/stamp like mm/dd/yyyy 00:00 AM, when I export the record, it comes out mm/dd/yyyy 11:00 PM, which is actually now a day earlier. We drop the time stamp for reports, so there is a boat load of inaccurate date records now.

A specific example would be a record that has a date/time stamp of 11/01/2017 00:00 AM becomes 10/31/2017 11:00 PM.

We do a find " *" (space asterisk) and replace with nothing to get 11/1/2017, but now it is an entire day off.

There are a lot of reports that are affected. Instead of adding columns and using a formula, I am looking for a VBA program to find these dates and correct them. Every record with "11:00 PM" in any column is the target.

Any ideas anyone?

 

[tonyyy]

simmerer,

You might consider the following...

Sub AdjustDate_1034619()
Application.ScreenUpdating = False
Dim r As Range
For Each r In ActiveSheet.UsedRange
    If IsDate(r.Value) Then
        If TimeValue(r.Value) = "11:00:00 PM" Then
            r.Value = r.Value + 1
            r.NumberFormat = "mm/dd/yyyy"
        End If
    End If
Next r
Application.ScreenUpdating = True
End Sub

Cheers,

tonyyy

 

[simmerer]

tonyyy,
Thanks for code! However I got a run-time error '13' error type mismatch at the line r.Value = r.Value + 1. So I played with it for a while and came up with this monster that takes six minutes to execute on a spread sheet with ten columns of dates and over 12,000 date fields. So it works, but I am pretty sure it is not near as efficient as it could be.

Sub AdjustDate()
Application.ScreenUpdating = False
Dim r As Range
For Each r In ActiveSheet.UsedRange
    If IsDate(r.Value) Then
 
      Cells.Replace What:="11:00 PM", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 End If

    Next r
    
    For Each r In ActiveSheet.UsedRange
    
     If r.NumberFormat = "m/d/yyyy" Then
       r.Value = DateAdd("d", 1, r.Value)
       End If
    Next r
       
     For Each r In ActiveSheet.UsedRange
     
     If IsDate(r.Value) Then
     Cells.Replace What:=" *", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 End If

    Next r
    

Application.ScreenUpdating = True
End Sub

 

[tonyyy]

...I got a run-time error '13' error type mismatch at the line r.Value = r.Value + 1...

Without seeing your actual data I can't determine the cause of the error. However, you might try pulling a line from your code into the original code...

Sub AdjustDate_1034619()
Application.ScreenUpdating = False
Dim r As Range
For Each r In ActiveSheet.UsedRange
    If IsDate(r.Value) Then
        If TimeValue(r.Value) = "11:00:00 PM" Then
'            r.Value = r.Value + 1
            [COLOR=#ff0000]r.Value = DateAdd("d", 1, r.Value)[/COLOR]
            r.NumberFormat = "mm/dd/yyyy"
        End If
    End If
Next r
Application.ScreenUpdating = True
End Sub

If you prefer to use the code from post #3 , you might try encompassing all the If/Then constructs into a single For Each loop...

Sub AdjustDate()
Application.ScreenUpdating = False
Dim r As Range
For Each r In ActiveSheet.UsedRange
    If IsDate(r.Value) Then
        Cells.Replace What:="11:00 PM", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    End If
    If r.NumberFormat = "m/d/yyyy" Then
        r.Value = DateAdd("d", 1, r.Value)
    End If
    If IsDate(r.Value) Then
        Cells.Replace What:=" *", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    End If
Next r
Application.ScreenUpdating = True
End Sub

Rather than three loops through 12,000 data fields, the code will only make a single loop.

If that's still not quick enough, and assuming the UsedRange contains only data and not formulas, you might consider reading the UsedRange into an array, performing the edits, then writing the array back to the range. Working with arrays are typically much faster than working with ranges.