Text to Date code needs refinement

[Unbridled]

I have a spreadsheet with some code to change text dates to true Excel-
formatted dates. Column B is what I am using for testing but would
like for this to work with any column containing date entries. I will
always start with row 2 of a date column to start the conversion
process since row 1 is my header row.

The code below works but with problem.
1. If there is not a date in column B, the calculation returns a
1/0/1900 value. I tried to correct this in the second If statement
but does not work.

I would like to do three things:
1. Be able to run this on any date column in the spreadsheet to the
end of the list
2. Leave blank cells blank
3. Optimize if possible

Any ideas appreciated.
*******************************************

Sub TextDateTest()
'The column calculating EOF() is column A which will always have a
record number
' with exception to blank records
'There are two sheets in this spreadsheet: ConExtract and data

Application.ScreenUpdating = False

Do
ActiveCell.Select

' This loop determines if same row in Column A is blank and
advances until the last record

If IsEmpty(ActiveCell.Offset(0, -1).Range("A1")) = False Then
Sheets("data").Select
Range("A1").Select
Selection.Copy
Sheets("ConExtract").Select

If IsEmpty(ActiveCell.Select) = False Then
'If this cell is empty this value blank , otherwise
01/0/1900 results
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "m/d/yyyy"
ActiveCell.Offset(1, 0).Range("A1").Select
End If
Else
Exit Do
End If
Loop
End Sub

 

[Joel]

Dates are number with 1 = Jan 1, 1900. Time start at 12);; AM at 0 and every
hours is 1/24. An empty cell is equal to zero which is a number and excel
returns 1/0/1900 when the cell is fromated as a date.

You probaly will never have dates in the early 1000' so you can test if the
date is greater than Jan 1, 2000 by doing this

If IsDate(ActiveCell) Then
if ActiveCell > Datavalue("1/1/2000") then

 

[Unbridled]

Dates are number with 1 = Jan 1, 1900.  Time start at 12);; AM at 0 and every
hours is 1/24.  An empty cell is equal to zero which is a number and excel
returns 1/0/1900  when the cell is fromated as a date.

You probaly will never have dates in the early 1000' so you can test if the
date is greater than Jan 1, 2000 by doing this

           If IsDate(ActiveCell)  Then
              if ActiveCell > Datavalue("1/1/2000") then














- Show quoted text -

Column A is a named range called "recno" and I wish to use it to
determine the end of the list; if that cell is empty, then that row
represents the end of the list. The Offset() function seems to use
absolute values instead of relative. Could I do something like:
ActiveCell.Offset(recno,0).Range("A1").Select to always point to
column A on the same row? Is there a better way?

 

[Joel]

See if this is better. The End method is the best way of getting to the last
cell. It works the same as the short cut keys on the worksheet using
Shft-Cntl and the arrow keys. Usually it is best to go to last row
Rows.Count (65536) and go up to get to last cell. You can go down but the
problem with down is if the starting cell is blank or the cell in the next
row is blank yoiu end up at row 65536. Try using the Shft-Cntl with the
arrows on a worksheet and you will see what happens. Using VBA

Range("A1").end(xldown)
Range("A" & Rows.Count).end(xlup)
Range("A1").end(xltoright)
Cells(1,columns.count).end(xltoleft)


Columns.Count = 256 which is column IV

Sub TextDateTest()
'The column calculating EOF() is column A which will always have a
'record number
' with exception to blank records
'There are two sheets in this spreadsheet: ConExtract and data

Application.ScreenUpdating = False

Set SrcSht = Activesheet
with SrcSht
FirstRow = .Range("recno").Row
RecnoCol = .Range("recno").column

if isempty(.cells(FirstRow + 1,RecnoCol)) then
LastRow = FirstRow
Else
LastRow = .Range("recno").end(xldown).Row
end if

.Rows(FirstRow & ":" & LastRow).Copy
end with

with Sheets("ConExtract")
LastRow = .Range("A" & Rows.Count).end(xlup).row
NewRow = LastRow + 1

.Rows(NewRow).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlMultiply
.Rows(NewRow).PasteSpecial _
Paste:=xlPasteformats
end with
end sub

 

[Unbridled]

See if this is better.  The End method is the best way of getting to the last
cell.  It works the same as the short cut keys on the worksheet using
Shft-Cntl and the arrow keys.  Usually it is best to go to last row
Rows.Count (65536) and go up to get to last cell.  You can go down but the
problem with down  is if the starting cell is blank or the cell in the next
row is blank yoiu end up at row 65536.  Try using the Shft-Cntl with the
arrows on a worksheet and you will see what happens.  Using VBA

Range("A1").end(xldown)
Range("A" & Rows.Count).end(xlup)
Range("A1").end(xltoright)
Cells(1,columns.count).end(xltoleft)

Columns.Count = 256 which is column IV

Sub TextDateTest()
   'The column calculating EOF() is column A which will always have a
   'record number
   ' with exception to blank records
   'There are two sheets in this spreadsheet: ConExtract and data

     Application.ScreenUpdating = False

   Set SrcSht = Activesheet
   with SrcSht
      FirstRow = .Range("recno").Row
      RecnoCol = .Range("recno").column

      if isempty(.cells(FirstRow + 1,RecnoCol)) then
         LastRow = FirstRow
      Else
         LastRow = .Range("recno").end(xldown).Row
      end if

      .Rows(FirstRow & ":" & LastRow).Copy
   end with

   with Sheets("ConExtract")
      LastRow = .Range("A" & Rows.Count).end(xlup).row
      NewRow = LastRow + 1

      .Rows(NewRow).PasteSpecial _
         Paste:=xlPasteValues, _
         Operation:=xlMultiply
      .Rows(NewRow).PasteSpecial _
         Paste:=xlPasteformats        
   end with
end sub






- Show quoted text -

Here is what I came up with. Column A is the control that determines
where the end of the list is. This makes the assumption that every
row in this column will have an entry. I also used a value of 1 for
cell A1 on a sheet called data. This number is used to solely for the
copy & paste special function. All I have to do is click on a date
cell in row 2, run the macro and everything below it is converted.
Empty cells stay empty (avoids #VALUE message if DateValue() is
used). I am sure it can be better but if someone can use it, here is
the code. Thanks to all.

Sub TextToDate()
'The column to test end of list is in column A
'There are two sheets in this spreadsheet: ConExtract and data
' Active cell is started at B2
Dim vrecno As Range
Dim OffvarCol As Long
'vrecno = Range("recno")
MsgBox "Click OK to start the conversion. Please wait, this may
take a while depending on records", vbInformation

Application.ScreenUpdating = False 'much faster operation,
remark out this line to watch the macro work
Do
ActiveCell.Select
OffvarCol = (ActiveCell.Column - 1) * -1 ' This determine Offset
() value to column A
' This loop determines if same row in Column A is blank
determining end of list
Sheets("data").Select
Range("A1").Select
Selection.Copy
Sheets("ConExtract").Select
If IsEmpty(ActiveCell.Offset(0, OffvarCol).Range("A1")) = False
Then
If IsEmpty(ActiveCell) = False Then
'If this cell is empty this value blank , otherwise
01/0/1900 results
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlMultiply, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.NumberFormat = "m/d/yyyy"
ActiveCell.Offset(1, 0).Range("A1").Select
'count = count + 1
Else
ActiveCell.Offset(1, 0).Range("A1").Select
End If
Else
Exit Do
End If
Loop
End Sub