Re: dates within a string

Tech-Archive recommends: Fix windows errors by optimizing your registry

On 22 Apr 2007 16:34:32 -0700, kmboucher@xxxxxxxxxx wrote:

the way I have written the the text and date in these cells are the
following

D21="PAYE "&TEXT(DATE(2004,1,1),"yyyy")
D22="SUPPS A "&YEAR(DATE(2005,6,1))
D23="SUPPS B "&YEAR(DATE(2005,10,15))

what I am looking to achieve is to have an another cell in the same
row deriving a date from the information
in that cell, D21, such as february 1, 2004 or from d22 june 1, 2005.
Any help with this problem
would be greatly appreciated!

If I understand you correctly, you wish to have a formula which will extract
the date you have entered in the DATE function argument. So in the examples
you give, you will extract:

January 1, 2004
June 1, 2005
October 15, 2005

That being the case, you will need to use a VBA Function (User Defined
Function or UDF).

To enter this function, <alt-F11> opens the VB Editor.

Ensure your project is highlighted in the Project Explorer window
Insert/Module and paste the code below into the window that opens.

To use the formula, enter it in some cell as

=GetDt(cell_ref)
or, in your case,

=GetDt(D21)

Format that cell as mmm dd, yyyy

================================================
Function GetDt(rg As Range) As Date
Dim oRegex As Object
Dim oMatchCollection As Object
Dim Y As Integer, M As Integer, D As Integer

Set oRegex = CreateObject("VBScript.RegExp")
oRegex.Pattern = "(\(DATE\()(\d{4}),(\d{1,2}),(\d{1,2})"

Set oMatchCollection = oRegex.Execute(rg.Formula)

Y = oMatchCollection(0).submatches(1)
M = oMatchCollection(0).submatches(2)
D = oMatchCollection(0).submatches(3)

GetDt = DateSerial(Y, M, D)

End Function
=========================================


The routine will return a #VALUE! error if there is no DATE function with
numeric arguments in cell_ref.

On the assumption that you might want to substitute cell references for those
arguments to the DATE function, I expanded the GetDt routine:

=========================================
Option Explicit

Function GetDt(rg As Range) As Date
Dim sFormula As String
Dim oRegex As Object
Dim oMatchCollection As Object
Dim YMD(1 To 3) As Integer
Dim i As Long
Dim Temp As Variant

sFormula = rg.Formula

Set oRegex = CreateObject("VBScript.RegExp")
oRegex.Pattern = "(\(DATE\()(.*?),(.*?),(.*?)\)"

Set oMatchCollection = oRegex.Execute(rg.Formula)

For i = 1 To 3
Temp = oMatchCollection(0).submatches(i)

If IsNumeric(Temp) Then
YMD(i) = Temp
Else
YMD(i) = Range(Temp).Value
End If
Next i

'Sanity Check

If YMD(1) < 1901 Or YMD(1) > 2200 Then
GetDt = Error(xlValue)
Exit Function
End If

GetDt = DateSerial(YMD(1), YMD(2), YMD(3))

End Function
==================================

This function should do what you want. However, if the year is not in the
range of 1901-2200, it will give a #VALUE! error.

I chose 1901 for the earliest allowable year because there is a difference in
how Excel interprets dates, compared with VBA, prior to March 1, 1900. This
could be handled in code, if necessary, but it probably isn't.

You can change the upper allowable year to anything up to 9999.

I did not check the values for month and day, as Excel will accept arguments
that are not in the range of 1-12; 1-31 -- merely doing the appropriate math to
change them to a valid date. For example:

DATE(2000,-3,0) --> 31 AUG 1999



--ron
.

Relevant Pages

  • Re: Output form to excel with range ????
    ... here is a long post with lots of useful code for exporting to excel. ... Dim varGetFileName As Variant 'File Name with Full Path ... Set objXLws = objXLWkb.ActiveSheet ... For Each cell In objXLws.Range ...
    (microsoft.public.access.formscoding)
  • RE: Offset(0, 1) and then Offset(1, 0)?
    ... Dim rngMyRange As Range ... Dim rngBlanks As Range ... Dim rng As Range ... How can I modify the code to get the cell ...
    (microsoft.public.excel.programming)
  • Re: Formulas containing hard coded values
    ... Dim R As Range, sdoit As String ... MsgBox "Cell contains hard codes" ... Dim Fml As String, LCtext As String ... For Each Rng In R.Precedents.Areas ...
    (microsoft.public.excel.programming)
  • Re: Macros to add a row in a word table
    ... Word MVP web site http://word.mvps.org ... Dim oTable As Table ... the last cell Set oRng = oTable.Rows.Range 'Add the last ... The code I posted in answer to your query removes the form field ...
    (microsoft.public.word.vba.general)
  • RE: Offset(0, 1) and then Offset(1, 0)?
    ... However, if there is another blank cell in this row, it overwrites the second ... Dim rngMyRange As Range ... Dim rngBlanks As Range ... Dim rng As Range ...
    (microsoft.public.excel.programming)