• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA to reformat dates

Eloise T

Eloise T

Active Member
I need a VBA to start in Row 3 and go down column G and change any date from whatever format it may be to mm/dd/yyyy ...until it reaches a blank cell.

I will be adding it to this which already contains 3 modules (ChanageCase, TRIMnCLEAN, and REDnBOLD) which act on other columns:

Code: 
Sub ChangeCase()
' ChangeCase is three VBA modules in one.  See ChangeCase(), TRIMnCLEAN(), and REDnBOLD() below.
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Formula Info" Then
    'If ws.Name <> "Formula Info" And ws.Name <>"Tech Rate" Then    Note: to add more just put (And ws.Name <> "name") before Then
'      Change "Formula Info" sheet name or you can use sheet index# instead of name.
          
            If ws.Cells(Rows.Count, 5).End(xlUp).Row > 2 Then
'          This line was added to "fix" Error 400 which was caused by blank tab(s).
'          The "Next Tech" tab has no data, and its header is in row 2.
'          The part which returns the last row of data is:  ws.Cells(Rows.Count, 5).End(xlUp).Row
'          which will return 3 or more as long as the worksheet has data; thus subtracting 2 from
'          this value returns any number from 1 upwards.  However, when the worksheet has no data,
'          the above code will return 2, and subtracting 2 from this = 0, which is an invalid row
'          number in Excel.  To check this, we test whether the value returned by the above code
'          is greater than 2; if so, we proceed further, else we exit.
'          The 5 in (Rows.Count, 5) tells it to start in the 5th row.
'----------------------------------------
'          Sub ChangeCase()
                With ws.[E3:F3].Resize(ws.Cells(Rows.Count, 5).End(xlUp).Row - 2)
'        > > > This VBA changes all characters in the array defined by Columns E and F to UPPER case.
'              E3:F3 array tells where to apply change(s).  (Rows.Count, 5) tells in which column to start.
                    .Value = .Parent.Evaluate(Replace("IF(#>"""",UPPER(#),"""")", "#", .Address))
                End With
'----------------------------------------
'          Sub TRIMnCLEAN()
                With ws.[A3:D3].Resize(ws.Cells(Rows.Count, 5).End(xlUp).Row - 2)
'        > > > This VBA removes leading and trailing spaces in the array of Columns A through F.
'              A3:D3 array tells where to apply change(s).  (Rows.Count, 5) tells in which column to start.
'              .Value = .Parent.Evaluate(Replace("IF(#>"""",TRIM(#),"""")", "#", .Address)) yields only removing leading and trailing spaces.
'              Added CLEAN to remove leading and trailing ASCII characters 0-31.
                    .Value = .Parent.Evaluate(Replace("IF(#>"""",TRIM(CLEAN(#)),"""")", "#", .Address))
                End With
'----------------------------------------
'          Sub REDnBOLD()
                For Each cll In ws.Range(ws.Cells(3, "C"), ws.Cells(ws.Rows.Count, "C").End(xlUp)).Cells
'        > > > This VBA segment changes the TV Model screen size between 70 and 90 inches to red and Bold and
'              starts in Row 3, Column C, and applies to each tab in the Excel workbook, except for tab "Formula Info" tab.
                With cll
                    x = Evaluate("MIN(IFERROR(FIND(ROW(10:99)," & .Address(0, 0, , 1) & "),""""))")
                        If x > 0 Then
                            y = CLng(Mid(cll.Value, x, 2))
                            If y >= 70 And y <= 90 Then
                                With .Characters(Start:=x, Length:=2).Font
                                    .FontStyle = "Bold"
                                    .Color = -16776961
                                End With
                            End If
                        End If
                End With
                Next cll
'              End Sub
'----------------------------------------
                              
            End If
        End If
    Next
End Sub

Thank you in advance.
 
Hi, Eloise T!
Give it a try:
Code: 
Option Explicit

Sub AnyIssueWithDates()
    ' constants
    Const ksFormat = "mm/dd/yyyy"
    ' declarations
    Dim lRow As Long, iColumn As Integer
    ' start
    lRow = 3
    iColumn = 7
    ' process
    With ActiveSheet
        Do While Len(.Cells(lRow, iColumn).Value) <> 0
            With .Cells(lRow, iColumn)
                If .NumberFormat <> ksFormat Then .NumberFormat = ksFormat
                lRow = lRow + 1
            End With
        Loop
    End With
    ' end
    Beep
End Sub
Regards!
 
SirJB7 said:
Hi, Eloise T!
Give it a try:
Code: 
Option Explicit

Sub AnyIssueWithDates()
    ' constants
    Const ksFormat = "mm/dd/yyyy"
    ' declarations
    Dim lRow As Long, iColumn As Integer
    ' start
    lRow = 3
    iColumn = 7
    ' process
    With ActiveSheet
        Do While Len(.Cells(lRow, iColumn).Value) <> 0
            With .Cells(lRow, iColumn)
                If .NumberFormat <> ksFormat Then .NumberFormat = ksFormat
                lRow = lRow + 1
            End With
        Loop
    End With
    ' end
    Beep
End Sub
Regards!
Click to expand...

I put your module in as the fourth module. I didn't get any error messages,
but it didn't change the dates to mm/dd/yyyy in column G (Completed).
See picture below.

upload_2017-7-19_15-59-28.png
Code: 
Sub ChangeCase()
' ChangeCase is three VBA modules in one.  See ChangeCase(), TRIMnCLEAN(), and REDnBOLD() below.
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Formula Info" Then
    'If ws.Name <> "Formula Info" And ws.Name <>"Tech Rate" Then    Note: to add more just put (And ws.Name <> "name") before Then
'      Change "Formula Info" sheet name or you can use sheet index# instead of name.
         
            If ws.Cells(Rows.Count, 5).End(xlUp).Row > 2 Then
'          This line was added to "fix" Error 400 which was caused by blank tab(s).
'          The "Next Tech" tab has no data, and its header is in row 2.
'          The part which returns the last row of data is:  ws.Cells(Rows.Count, 5).End(xlUp).Row
'          which will return 3 or more as long as the worksheet has data; thus subtracting 2 from
'          this value returns any number from 1 upwards.  However, when the worksheet has no data,
'          the above code will return 2, and subtracting 2 from this = 0, which is an invalid row
'          number in Excel.  To check this, we test whether the value returned by the above code
'          is greater than 2; if so, we proceed further, else we exit.
'          The 5 in (Rows.Count, 5) tells it to start in the 5th row.
'----------------------------------------
'          Sub ChangeCase()
                With ws.[E3:F3].Resize(ws.Cells(Rows.Count, 5).End(xlUp).Row - 2)
'        > > > This VBA changes all characters in the array defined by Columns E and F to UPPER case.
'              E3:F3 array tells where to apply change(s).  (Rows.Count, 5) tells in which column to start.
                    .Value = .Parent.Evaluate(Replace("IF(#>"""",UPPER(#),"""")", "#", .Address))
                End With
'----------------------------------------
'          Sub TRIMnCLEAN()
                With ws.[A3:D3].Resize(ws.Cells(Rows.Count, 5).End(xlUp).Row - 2)
'        > > > This VBA removes leading and trailing spaces in the array of Columns A through F.
'              A3:D3 array tells where to apply change(s).  (Rows.Count, 5) tells in which column to start.
'              .Value = .Parent.Evaluate(Replace("IF(#>"""",TRIM(#),"""")", "#", .Address)) yields only removing leading and trailing spaces.
'              Added CLEAN to remove leading and trailing ASCII characters 0-31.
                    .Value = .Parent.Evaluate(Replace("IF(#>"""",TRIM(CLEAN(#)),"""")", "#", .Address))
                End With
'----------------------------------------
'          Sub REDnBOLD()
                For Each cll In ws.Range(ws.Cells(3, "C"), ws.Cells(ws.Rows.Count, "C").End(xlUp)).Cells
'        > > > This VBA segment changes the TV Model screen size between 70 and 90 inches to red and Bold and
'              starts in Row 3, Column C, and applies to each tab in the Excel workbook, except for tab "Formula Info" tab.
                With cll
                    x = Evaluate("MIN(IFERROR(FIND(ROW(10:99)," & .Address(0, 0, , 1) & "),""""))")
                        If x > 0 Then
                            y = CLng(Mid(cll.Value, x, 2))
                            If y >= 70 And y <= 90 Then
                                With .Characters(Start:=x, Length:=2).Font
                                    .FontStyle = "Bold"
                                    .Color = -16776961
                                End With
                            End If
                        End If
                End With
                Next cll
'              End Sub
'---------------------------------------
'          Sub AnyIssueWithDates()
    ' constants
                Const ksFormat = "mm/dd/yyyy"
    ' declarations
                Dim lRow As Long, iColumn As Integer
    ' start
                    lRow = 3
                    iColumn = 7
    ' process
                    With ActiveSheet
                        Do While Len(.Cells(lRow, iColumn).Value) <> 0
                            With .Cells(lRow, iColumn)
                                If .NumberFormat <> ksFormat Then .NumberFormat = ksFormat
                                    lRow = lRow + 1
                            End With
                        Loop
                    End With
    ' end
                    Beep
'              End Sub
'----------------------------------------
            End If
        End If
    Next
End Sub
 
Hi, Eloise T!
I tested it on a dozen of rows with different date formats and it worked. Please upload a sample file with dates in col G from row 3 in advance where it doesn't work. Thanks.
Regards!
 
SirJB7 said:
Hi, Eloise T!
I tested it on a dozen of rows with different date formats and it worked. Please upload a sample file with dates in col G from row 3 in advance where it doesn't work. Thanks.
Regards!
Click to expand...

My error! It does work! EXCEPT...note uploaded file. It stopped working at row 1473 due to the blank. Can we fix that?
 
Hi, Eloise T!

You now say...
Eloise T said:
It stopped working at row 1473 due to the blank. Can we fix that?
Click to expand...
but in the 1st post you said...
Eloise T said:
I need a VBA to start in Row 3 and go down column G and change any date from whatever format it may be to mm/dd/yyyy ...until it reaches a blank cell.
Click to expand...
<bold red is mine>
We can... but what are we supposed to do? Follow 1st or last requirement?

Assuming David Copperfield is whispering at my ears, try this:
Code: 
Option Explicit

Sub AnyIssueWithDates()
    ' constants
    Const ksFormat = "mm/dd/yyyy"
    ' declarations
    Dim lRow As Long, iColumn As Integer, lRowest As Long
    ' start
    lRow = 3
    iColumn = 7
    ' process
    With ActiveSheet
        lRowest = .Cells(.Rows.Count, iColumn).End(xlUp).Row
        Do While lRow <= lRowest
        Debug.Print lRow
            With .Cells(lRow, iColumn)
                If Len(.Cells(lRow, iColumn).Value) > 0 Then _
                    If .NumberFormat <> ksFormat Then .NumberFormat = ksFormat
                lRow = lRow + 1
            End With
        Loop
    End With
    ' end
    Beep
End Sub

This will process all data in column G, from row 3 until last used row, skipping blank cells.

But, and as my old friend b(ut)ob(ut)hc @bobhc taught me -there's always a but-, if you want to do is what I suppose you should want to do, and it's changing format of intermediate blank cells too, then just comment/remove this line:
Code: 
                If Len(.Cells(lRow, iColumn).Value) > 0 Then _

Just advise if any issue.
Regards!
 
SirJB7 said:
Hi, Eloise T!

You now say...

but in the 1st post you said...
<bold red is mine>
We can... but what are we supposed to do? Follow 1st or last requirement?

Assuming David Copperfield is whispering at my ears, try this:
Code: 
Option Explicit

Sub AnyIssueWithDates()
    ' constants
    Const ksFormat = "mm/dd/yyyy"
    ' declarations
    Dim lRow As Long, iColumn As Integer, lRowest As Long
    ' start
    lRow = 3
    iColumn = 7
    ' process
    With ActiveSheet
        lRowest = .Cells(.Rows.Count, iColumn).End(xlUp).Row
        Do While lRow <= lRowest
        Debug.Print lRow
            With .Cells(lRow, iColumn)
                If Len(.Cells(lRow, iColumn).Value) > 0 Then _
                    If .NumberFormat <> ksFormat Then .NumberFormat = ksFormat
                lRow = lRow + 1
            End With
        Loop
    End With
    ' end
    Beep
End Sub

This will process all data in column G, from row 3 until last used row, skipping blank cells.

But, and as my old friend b(ut)ob(ut)hc @bobhc taught me -there's always a but-, if you want to do is what I suppose you should want to do, and it's changing format of intermediate blank cells too, then just comment/remove this line:
Code: 
                If Len(.Cells(lRow, iColumn).Value) > 0 Then _

Just advise if any issue.
Regards!
Click to expand...
You are so right. I did say, " ...until it reaches a blank cell." That just goes to show you I don't know my own data! :)

I thought ALL of column G was dates. I forgot there were exceptions where the whole row could be blank...which of course includes column G.

BTW, what did you mean by, "changing format of intermediate blank cells?"

I guess it just needs to go until...the same as the first three modules/sub routines that are Changing Case, Red bolding, and TRIMing and CLEANing.
 
Last edited:
SirJB7 said:
Hi, Eloise T!

You now say...

but in the 1st post you said...
<bold red is mine>
We can... but what are we supposed to do? Follow 1st or last requirement?

Assuming David Copperfield is whispering at my ears, try this:
Code: 
Option Explicit

Sub AnyIssueWithDates()
    ' constants
    Const ksFormat = "mm/dd/yyyy"
    ' declarations
    Dim lRow As Long, iColumn As Integer, lRowest As Long
    ' start
    lRow = 3
    iColumn = 7
    ' process
    With ActiveSheet
        lRowest = .Cells(.Rows.Count, iColumn).End(xlUp).Row
        Do While lRow <= lRowest
        Debug.Print lRow
            With .Cells(lRow, iColumn)
                If Len(.Cells(lRow, iColumn).Value) > 0 Then _
                    If .NumberFormat <> ksFormat Then .NumberFormat = ksFormat
                lRow = lRow + 1
            End With
        Loop
    End With
    ' end
    Beep
End Sub

This will process all data in column G, from row 3 until last used row, skipping blank cells.

But, and as my old friend b(ut)ob(ut)hc @bobhc taught me -there's always a but-, if you want to do is what I suppose you should want to do, and it's changing format of intermediate blank cells too, then just comment/remove this line:
Code: 
                If Len(.Cells(lRow, iColumn).Value) > 0 Then _

Just advise if any issue.
Regards!
Click to expand...
Thank you for all your effort. It works....except it doesn't go from tab to tab running the date function in Column G...I have to run the VBA in each tab for it to work. The other 3 sub routines work from tab to tab automatically. What needs adjusted for the 4th sub routine with the dates to go from tab to tab?

Lastly, what does "Debug.Print lRow" do?

Code: 
Sub ChangeCase()
' ChangeCase is three VBA modules in one.  See ChangeCase(), TRIMnCLEAN(), and REDnBOLD() below.
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Formula Info" Then
    'If ws.Name <> "Formula Info" And ws.Name <>"Tech Rate" Then    Note: to add more just put (And ws.Name <> "name") before Then
'      Change "Formula Info" sheet name or you can use sheet index# instead of name.
           
            If ws.Cells(Rows.Count, 5).End(xlUp).Row > 2 Then
'          This line was added to "fix" Error 400 which was caused by blank tab(s).
'          The "Next Tech" tab has no data, and its header is in row 2.
'          The part which returns the last row of data is:  ws.Cells(Rows.Count, 5).End(xlUp).Row
'          which will return 3 or more as long as the worksheet has data; thus subtracting 2 from
'          this value returns any number from 1 upwards.  However, when the worksheet has no data,
'          the above code will return 2, and subtracting 2 from this = 0, which is an invalid row
'          number in Excel.  To check this, we test whether the value returned by the above code
'          is greater than 2; if so, we proceed further, else we exit.
'          The 5 in (Rows.Count, 5) tells it to start in the 5th row.
'----------------------------------------
'          Sub ChangeCase()
                With ws.[E3:F3].Resize(ws.Cells(Rows.Count, 5).End(xlUp).Row - 2)
'        > > > This VBA changes all characters in the array defined by Columns E and F to UPPER case.
'              E3:F3 array tells where to apply change(s).  (Rows.Count, 5) tells in which column to start.
                    .Value = .Parent.Evaluate(Replace("IF(#>"""",UPPER(#),"""")", "#", .Address))
                End With
'----------------------------------------
'          Sub TRIMnCLEAN()
                With ws.[A3:D3].Resize(ws.Cells(Rows.Count, 5).End(xlUp).Row - 2)
'        > > > This VBA removes leading and trailing spaces in the array of Columns A through F.
'              A3:D3 array tells where to apply change(s).  (Rows.Count, 5) tells in which column to start.
'              .Value = .Parent.Evaluate(Replace("IF(#>"""",TRIM(#),"""")", "#", .Address)) yields only removing leading and trailing spaces.
'              Added CLEAN to remove leading and trailing ASCII characters 0-31.
                    .Value = .Parent.Evaluate(Replace("IF(#>"""",TRIM(CLEAN(#)),"""")", "#", .Address))
                End With
'----------------------------------------
'          Sub REDnBOLD()
                For Each cll In ws.Range(ws.Cells(3, "C"), ws.Cells(ws.Rows.Count, "C").End(xlUp)).Cells
'        > > > This VBA segment changes the TV Model screen size between 70 and 90 inches to red and Bold and
'              starts in Row 3, Column C, and applies to each tab in the Excel workbook, except for tab "Formula Info" tab.
                With cll
                    x = Evaluate("MIN(IFERROR(FIND(ROW(10:99)," & .Address(0, 0, , 1) & "),""""))")
                        If x > 0 Then
                            y = CLng(Mid(cll.Value, x, 2))
                            If y >= 70 And y <= 90 Then
                                With .Characters(Start:=x, Length:=2).Font
                                    .FontStyle = "Bold"
                                    .Color = -16776961
                                End With
                            End If
                        End If
                End With
                Next cll
'              End Sub
'---------------------------------------
'          Sub AnyIssueWithDates()
    ' constants
                Const ksFormat = "mm/dd/yyyy"
    ' declarations
                Dim lRow As Long, iColumn As Integer, lRowest As Long
    ' start        1Row starts at row 3, iColumn starts at column G(7)
                    lRow = 3
                    iColumn = 7
    ' process
                    With ActiveSheet
                        lRowest = .Cells(.Rows.Count, iColumn).End(xlUp).Row
                        Do While lRow <= lRowest
                            Debug.Print lRow
                                With .Cells(lRow, iColumn)
                                '    If Len(.Cells(lRow, iColumn).Value) > 0 Then
                                  If .NumberFormat <> ksFormat Then .NumberFormat = ksFormat
                                lRow = lRow + 1
                            End With
                        Loop
                    End With
    ' end
                    Beep
'              End Sub
'----------------------------------------
            End If
        End If
    Next
End Sub
 
Hi, Eloise T!

Eloise T said:
It works....except it doesn't go from tab to tab running the date function in Column G...I have to run the VBA in each tab for it to work. The other 3 sub routines work from tab to tab automatically. What needs adjusted for the 4th sub routine with the dates to go from tab to tab?
Click to expand...
Am I wrong or you just asked for working on column G, didn't mention anything about multiple sheets and also said that YOU were going to add it to some other code?
Eloise T said:
I need a VBA to start in Row 3 and go down column G and change any date from whatever format it may be to mm/dd/yyyy ...until it reaches a blank cell.

I will be adding it to this which already contains 3 modules (ChanageCase, TRIMnCLEAN, and REDnBOLD) which act on other columns:
Click to expand...

Eloise T said:
Lastly, what does "Debug.Print lRow" do?
Click to expand...
It just prints the row number that is being processed, only for testing and debugging purposes. I omitted to delete it, sorry.

Now, let me see if this works for your 3-sheet requirement, I'll try to look as shallow as I can into your other code to get this info.

It wasn't too hard to figure the changes, in fact only one. Change this line:
Code: 
  With ActiveSheet
by this one:
Code: 
  With ws

I hope we're done with this.

Regards!
 
SirJB7 said:
Hi, Eloise T!


Am I wrong or you just asked for working on column G, didn't mention anything about multiple sheets and also said that YOU were going to add it to some other code?



It just prints the row number that is being processed, only for testing and debugging purposes. I omitted to delete it, sorry.

Now, let me see if this works for your 3-sheet requirement, I'll try to look as shallow as I can into your other code to get this info.

It wasn't too hard to figure the changes, in fact only one. Change this line:
Code: 
  With ActiveSheet
by this one:
Code: 
  With ws

I hope we're done with this.

Regards!
Click to expand...
THANK YOU, SIR! That worked!....completely!
 
Hi, Eloise T!
Glad you solved it. Thanks for your feedback and welcome back whenever needed or wanted.
Regards!
 
You must log in or register to reply here.
Back
Top