Converting date format in range of cells

Question

This code works, but I was wondering if there's a way to get excel to identify the date data more easily. This comes from an imported file where the date field(s) come in as text and in a European format.

Company specific information has been changed. the function FndLast gets the last row of the data.

Sub FormatTheDates()



Dim rng As Range
Dim lstRow As Long
Dim StartRow As Long


Set rng = sheets("MySheet").Cells.Find("Keyfield")

If Not rng Is Nothing Then
    With sheets("MySheet")
    ****Data starts one row below key field***
        StartRow = rng.Row + 1
        lstRow = FndLast(1, .Cells)
        Set rng = .Range(.Cells(StartRow, 5).Address, .Cells(lstRow, 5).Address)
        rng.NumberFormat = "m/d/yyyy"
        rng.value = rng.value
    End With
End If





Set rng = sheets("MySheet2").Cells.Find("Keyfield")

If Not rng Is Nothing Then
    With sheets("MySheet2")
        StartRow = rng.Row + 1
        lstRow = FndLast(1, .Cells)
        Set rng = .Range(.Cells(StartRow, 7).Address, .Cells(lstRow, 7).Address)
        rng.NumberFormat = "m/d/yyyy"
        rng.value = rng.value
    End With
End If




End Sub

The fndlast function takes a 1,2, or 3 as a parameter and finds the last row, column or cell on a sheet. I use this as opposed to usedrange as it returns the last one with data.

Function FndLast(choice As Long, rng As Range)

' 1 = last row
' 2 = last column
' 3 = last cell

Dim lrw As Long
Dim lCol As Long

Select Case choice

Case 1:
    On Error Resume Next
    FndLast = rng.Find(What:="*", _
                    After:=rng.Cells(1), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
    On Error GoTo 0

Case 2:
    On Error Resume Next
    FndLast = rng.Find(What:="*", _
                    After:=rng.Cells(1), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Column
    On Error GoTo 0

Case 3:
    On Error Resume Next
    lrw = rng.Find(What:="*", _
                   After:=rng.Cells(1), _
                   LookAt:=xlPart, _
                   LookIn:=xlFormulas, _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlPrevious, _
                   MatchCase:=False).Row
    On Error GoTo 0

    On Error Resume Next
    lCol = rng.Find(What:="*", _
                    After:=rng.Cells(1), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Column
    On Error GoTo 0

    On Error Resume Next
    FndLast = rng.Parent.Cells(lrw, lCol).Address(False, False)
    If Err.Number > 0 Then
        Last = rng.Cells(1).Address(False, False)
        Err.Clear
    End If
    On Error GoTo 0

End Select
End Function

As I said, all of this works, and fairly quickly, but it feels like the Range.value = range.value seems unnecessary. Is it, or is this just an Excel quirk that I need to work around in order for my code to work?

Answer 1

In solving the overall problem of date conversion, your code makes a few assumptions that have tripped me up in the past.

1. Always use Option Explicit
2. Set references to the workbook and your worksheets
3. Make a habit of trying to use arrays instead of cells directly from the worksheet

Using these habits along will greatly improve your code. In particular, notice in the example below how all the variables end up being fully referenced back to the parent sheet and workbook so that you (and the VBA) never gets confused.

I found it less useful to have a single function that determined the last row or column or cell, since that generated more code than I usually use to find it. Instead, I arrived at a different decomposition of the problem into functions.

While you created a function to find the last row/cell/column, you also have a repeated need to convert the dates within an area. So the "main" routine breaks down into an easily understandable set of repeatable steps (functions):

Option Explicit

Public Sub main()
    Dim wb As Workbook
    Dim targetDateSheet As Worksheet
    Dim myDateArea As Range
    Set wb = ThisWorkbook

    Set targetDateSheet = wb.Sheets("MySheet1")
    Set myDateArea = GetDataArea(targetDateSheet, "Start")
    ConvertDates myDateArea

    Set targetDateSheet = wb.Sheets("MySheet2")
    Set myDateArea = GetDataArea(targetDateSheet, "Keyfield")
    ConvertDates myDateArea
End Sub

The GetDataArea function quickly determines where the dates are based on a search for the key field:

Private Function GetDataArea(ByRef targetSheet As Worksheet, _
                             ByRef keyField As String) As Range
    Dim theArea As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim numRows As Long
    Dim numCols As Long
    With targetSheet
        Set theArea = .Cells.Find(keyField)
        If Not theArea Is Nothing Then
            lastRow = .Cells(.Cells.Rows.Count, theArea.Cells(1, 1).Column).End(xlUp).Row
            lastCol = .Cells(theArea.Cells(1, 1).Row, .Cells.Columns.Count).End(xlToLeft).Column
            numRows = lastRow - theArea.Cells(1, 1).Row
            numCols = lastCol - theArea.Cells(1, 1).Column + 1
            '--- assume the first row contains headers for each column, so offset
            Set GetDataArea = theArea.Offset(1, 0).Resize(numRows, numCols)
        Else
            theArea = Nothing
        End If
    End With
End Function

I've found it much quicker and simpler to find the last row and column using the above method, rather than the Find method.

Converting the dates in the given range then breaks down into these pseudo-steps:

1. copy the cell range into a memory array (for speed and ease of referencing)
2. loop through the entire array and detect the date data and convert it to the Excel serial date (numerical) value
3. copy the converted array back to the worksheet range and set the desired date format

It's very important NOT to assume that the text string you find is read by excel as a date string. It may or may not be recognized that way. In order to guarantee you're converting the string to an Excel date value, you should use the DateSerial function as shown and then format the worksheet cells as you need.

This becomes:

Private Sub ConvertDates(ByRef theArea As Range)
    Dim area As Variant
    area = theArea                               'copied to memory array

    '--- look for a string pattern with two "/"s and assume that value
    '    is a European-format date string
    Dim i As Long
    Dim j As Long
    For i = LBound(area, 1) To UBound(area, 1)
        For j = LBound(area, 2) To UBound(area, 2)
            Dim pos1 As Long
            Dim pos2 As Long
            pos1 = 0
            pos2 = 0
            pos1 = InStr(1, area(i, j), "/", vbTextCompare)
            If pos1 > 0 Then
                pos2 = InStr(pos1 + 1, area(i, j), "/", vbTextCompare)
            End If
            If (pos1 > 0) And (pos2 > 0) Then
                Dim dd As Long
                Dim mm As Long
                Dim yy As Long
                dd = CLng(Left(area(i, j), pos1 - 1))
                mm = CLng(Mid(area(i, j), pos1 + 1, pos2 - pos1 - 1))
                yy = CLng(Right(area(i, j), Len(area(i, j)) - pos2))
                area(i, j) = DateSerial(yy, mm, dd)
            End If
        Next j
    Next i

    '--- now put the array back onto the worksheet and set the
    '    number format for those cells to the desired
    theArea = area
    theArea.Cells.NumberFormat = "dd-mmm-yyyy"
End Sub

Note that I'm testing each value to make certain it's a date with two "/" appearing before I attempt to convert it.

For convenience, here's the whole module in a single area:

Option Explicit

Public Sub main()
    Dim wb As Workbook
    Dim targetDateSheet As Worksheet
    Dim myDateArea As Range
    Set wb = ThisWorkbook

    Set targetDateSheet = wb.Sheets("MySheet1")
    Set myDateArea = GetDataArea(targetDateSheet, "Start")
    ConvertDates myDateArea

    Set targetDateSheet = wb.Sheets("MySheet2")
    Set myDateArea = GetDataArea(targetDateSheet, "Keyfield")
    ConvertDates myDateArea
End Sub

Private Function GetDataArea(ByRef targetSheet As Worksheet, _
                             ByRef keyField As String) As Range
    Dim theArea As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim numRows As Long
    Dim numCols As Long
    With targetSheet
        Set theArea = .Cells.Find(keyField)
        If Not theArea Is Nothing Then
            lastRow = .Cells(.Cells.Rows.Count, theArea.Cells(1, 1).Column).End(xlUp).Row
            lastCol = .Cells(theArea.Cells(1, 1).Row, .Cells.Columns.Count).End(xlToLeft).Column
            numRows = lastRow - theArea.Cells(1, 1).Row
            numCols = lastCol - theArea.Cells(1, 1).Column + 1
            '--- assume the first row contains headers for each column, so offset
            Set GetDataArea = theArea.Offset(1, 0).Resize(numRows, numCols)
        Else
            theArea = Nothing
        End If
    End With
End Function

Private Sub ConvertDates(ByRef theArea As Range)
    Dim area As Variant
    area = theArea                               'copied to memory array

    '--- look for a string pattern with two "/"s and assume that value
    '    is a European-format date string
    Dim i As Long
    Dim j As Long
    For i = LBound(area, 1) To UBound(area, 1)
        For j = LBound(area, 2) To UBound(area, 2)
            Dim pos1 As Long
            Dim pos2 As Long
            pos1 = 0
            pos2 = 0
            pos1 = InStr(1, area(i, j), "/", vbTextCompare)
            If pos1 > 0 Then
                pos2 = InStr(pos1 + 1, area(i, j), "/", vbTextCompare)
            End If
            If (pos1 > 0) And (pos2 > 0) Then
                Dim dd As Long
                Dim mm As Long
                Dim yy As Long
                dd = CLng(Left(area(i, j), pos1 - 1))
                mm = CLng(Mid(area(i, j), pos1 + 1, pos2 - pos1 - 1))
                yy = CLng(Right(area(i, j), Len(area(i, j)) - pos2))
                area(i, j) = DateSerial(yy, mm, dd)
            End If
        Next j
    Next i

    '--- now put the array back onto the worksheet and set the
    '    number format for those cells to the desired
    theArea = area
    theArea.Cells.NumberFormat = "dd-mmm-yyyy"
End Sub