macro for convert data format into another format 3

[selenus]

I need help with macro: I have Excel workbook containing spreadsheets with data format as follows:

2003.gada "08" Janvaris
2003.gada 12. Februaris
2003.gada "25." marta
2003.gada "22." aprilis
2003.gada "12." maijs
2003.gada "15." junijs
2003.gada 08. Julijs
2003.gada 05. Augusts
2003.gada "02." septembris
2003.gada "06." Oktobris
2003.gada "04." Novembris
2003.gada "01" Decembris

I need macro that will sequencely scan spreadsheets for this data, extract data, and store it into separate spreadsheet into following format: dd-mm-yyyy (as list).
example:
2003.gada "08" Janvaris --> need get: 08-01-2003


By default, data stored in F5 cell, but here is one small problem: some spreadsheets formatting may differ a little, i.e. cells with data may be differ(float from E5 to G5), for vertical also, for F4 - F6. Some Month name may differs in syntax a little also, commas may missing.

 

[VBAjedi]

Your code will only be reliable to the degree that you can identify things that are always true about your data. Once you have those, you can start working towards what you're after.

In the data sample you gave, it looks like the year always comes first, followed by a period. And it looks like the day is always the first number after ".gada". The month may be tougher if the syntax sometimes varies, but it looks like it is always the last word in the string, and it looks like you might be able to rely on the first three letters of the word to determine the month.

Let us know if these observations/rules are correct, and we can suggest code that uses them to get what you are after.

VBAjedi

 

[ETID]

Here is a start...

AS VBAJedi states... it does not account for all scenerios and assumes that these "dates" are the only data present.



Public usedRng As Range
Public usedrngadd As String
Public i As Integer
Sub Transcribe_dates()
For i = 1 To ActiveWorkbook.Sheets.Count
clean_data
DetermineUsedRange
For Each cell In Range(usedrngadd)
x = Trim(Range(cell.Address).Text)
x = Application.WorksheetFunction.Clean(x)
If Val(x) >= 1900 Then
x = Left(x, 8)

Range(cell.Address) = Right(x, 2) + "-" + Mid(x, 5, 2) + "-" + Left(x, 4)

Else
End If
Next cell

Next i

End Sub
Sub clean_data()
Sheets(i).Select
Cells.Select
For m = 0 To 11
mon_text = Array("Janvaris", "Februaris", "marta", "aprilis", "maijs", "junijs", "Julijs", "Augusts", "septembris", "Oktobris", "Novembris", "Decembris")
mon_val = Array("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12")
Selection.Replace What:=mon_text(m), Replacement:=mon_val(m), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next m

clutter = Array(".", "gada", Chr$(34), " ")
For j = 0 To 3
Selection.Replace What:=clutter(j), Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next j

End Sub

Sub DetermineUsedRange()

On Error Resume Next
Dim usedRng As Range
Determine_UsedRange usedRng
usedrngadd = usedRng.Address
End Sub
Sub Determine_UsedRange(ByRef theRng As Range)
Dim FirstRow As Integer, FirstCol As Integer, _
LastRow As Integer, LastCol As Integer
On Error GoTo handleError
FirstRow = Cells.Find(What:="*", _
SearchDirection:=xlNext, _
SearchOrder:=xlByRows).Row
FirstCol = Cells.Find(What:="*", _
SearchDirection:=xlNext, _
SearchOrder:=xlByColumns).Column
LastRow = Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
LastCol = Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column

Set theRng = Range(Cells(FirstRow, FirstCol), _
Cells(LastRow, LastCol))
handleError:
End Sub

 

[selenus]

VBAjedi,
you are right, this rules are correct.
Year always comes first,("gada" = year)
Day is always the first number after ".gada"
Then goes month, and yes, it always the last word in the string;
And yes, its true -I can to rely on the first three letters of the word to determine the month.

ETID, will try your solution.

 

[selenus]

Hmm, something unclear, this macro goes in Module? Macro need be in same workbook with spreadsheets containing this data, or it need be in separate workbook and both workbooks need be opened? There are 3 macro shown: Clean_data, DetermineUsedRange, Transcribe_dates

 

[ETID]

paste all into a new module of the worksheet that has ONLY dates and the run "Transcribe_dates

 

[selenus]

No, I can no create worksheet that has ONLY dates. This dates - part of invoices spreadsheets.

 

[ETID]

Then you must edit/modify to work with only a specified column...

 

[ETID]

'Something like this maybe?...



Public usedRng As Range
Public usedrngadd As String
Public i As Integer
Sub Transcribe_dates()
For i = 1 To ActiveWorkbook.Sheets.Count
clean_data
DetermineUsedRange
For Each cell In Range(usedrngadd)
x = Trim(Range(cell.Address).Text)
x = Application.WorksheetFunction.Clean(x)
If Val(x) >= 1900 Then
x = Left(x, 8)

Range(cell.Address) = Right(x, 2) + "-" + Mid(x, 5, 2) + "-" + Left(x, 4)

Else
End If
Next cell

Next i

End Sub
Sub clean_data()
Sheets(i).Select
Cells.Select
For m = 0 To 11
mon_text = Array("Janvaris", "Februaris", "marta", "aprilis", "maijs", "junijs", "Julijs", "Augusts", "septembris", "Oktobris", "Novembris", "Decembris")
mon_val = Array("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12")
Selection.Replace What:=mon_text(m), Replacement:=mon_val(m), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next m

clutter = Array(".", "gada", Chr$(34), " ")
For j = 0 To 3
Selection.Replace What:=clutter(j), Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next j

End Sub

Sub DetermineUsedRange()

On Error Resume Next
Dim usedRng As Range
Determine_UsedRange usedRng
usedrngadd = usedRng.Address
End Sub
Sub Determine_UsedRange(ByRef theRng As Range)
rng_in = InputBox("Enter the Column Letter")
Set theRng = Range(rng_in + ":" + rng_in)
handleError:

End Sub

 

[selenus]

Some amplification: I have created the full list of my documents(few columns), and all data now stored in one spreadsheet. The date of my docs is among these data, and its located in column E (start from E2). So, no problem with formatting- all date located in one specified column. The only thing is some documents is without date(just empty cell) Could you adjust the code now?

 

[ETID]

'This should not be affected by empty data cells...

Public rng_in As String
Public usedRng As Range
Public usedrngadd As String
Public i As Integer
Sub Transcribe_dates()
For i = 1 To ActiveWorkbook.Sheets.Count
clean_data
DetermineUsedRange
For Each cell In Range(usedrngadd)
x = Trim(Range(cell.Address).Text)
x = Application.WorksheetFunction.Clean(x)
If Val(x) >= 1900 Then
x = Left(x, 8)
Range(cell.Address) = Right(x, 2) + "-" + Mid(x, 5, 2) + "-" + Left(x, 4)
Else
End If
Next cell
Next i
End Sub
Sub clean_data()
Sheets(i).Select
rng_in = InputBox("Enter the Column Letter")
Range(rng_in + ":" + rng_in).Select
mon_text = Array("Janvaris", "Februaris", "marta", "aprilis", "maijs", "junijs", "Julijs", "Augusts", "septembris", "Oktobris", "Novembris", "Decembris")
mon_val = Array("01", "02", "03", "04", "05", "06", "07", "08", "09", "10", "11", "12")
For m = 0 To 11
Selection.Replace What:=mon_text(m), Replacement:=mon_val(m), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next m
clutter = Array(".", "gada", Chr$(34), " ")
For j = 0 To 3
Selection.Replace What:=clutter(j), Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next j
End Sub
Sub DetermineUsedRange()
On Error Resume Next
Dim usedRng As Range
Determine_UsedRange usedRng
usedrngadd = usedRng.Address
End Sub
Sub Determine_UsedRange(ByRef theRng As Range)
Set theRng = Range(rng_in + ":" + rng_in)
handleError:
End Sub

 

[byundt]

Assuming that you have the Latvian language kit for your copy of Excel, adding 0 to a date string like "08 Janvaris 2003" should result in a date serial number. If so, then the following worksheet formula will do the conversion:
=(REPLACE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(LOWER(A1),".gada",""),CHAR(34),""),CHAR(160),""),1,5,"")& " " & LEFT(A1,4))+0

The CHAR(160) is in there to remove a blank space that differs from the usual ASCII 32. I assume this comes from the data source.

The VBA to convert all the dates in a fixed column would be:

Sub DateConversion()
Dim cel As Range
Dim str As String
On Error Resume Next
ActiveSheet.Copy after:=ActiveSheet.Index
For Each cel In Range(Cells(1, 1), Cells(65536, 1).End(xlUp))
    str = Replace(Replace(Replace(LCase(cel), ".gada", ""), Chr(34), ""), Chr(160), "")
    str = Right(str, Len(str) - 5) & " " & Left(cel, 4)
    cel = DateValue(str)
    cel.NumberFormat = "dd-mm-yyyy"
Next cel
End Sub

Brad

 

[byundt]

Here is a sub using RegExp to identify the cells containing dates and copy them to column A of a new worksheet. This sub goes in a regular module sheet.

Sub DateConversion()
Dim cel As Range
Dim RgExp As Object
Dim temp As Variant
Dim str As String
Dim i As Long
Dim ws As Worksheet, wsOld As Worksheet
Set wsOld = ActiveSheet
Worksheets.Add after:=ActiveSheet
ActiveSheet.Name = "Consolidated"
Set RgExp = CreateObject("VBScript.RegExp")
RgExp.Pattern = "(\d{4})\x2Egada\s*\x22?(\d{2})\x2E?\x22?\s*([A-Za-z]+)"
On Error Resume Next
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "Consolidated" Then
        For Each cel In ws.Range("E4:G6")
            If Not IsError(cel) Then
                If cel <> "" And RgExp.test(LCase(cel.Value)) Then
                    str = RgExp.Replace(LCase(cel), "$2 $3 $1")
                    temp = DateValue(str)
                    i = i + 1
                    If Err > 0 Then
                        Cells(i, 1) = str
                        Err.Clear
                    Else
                        Cells(i, 1) = temp
                    End If
                End If
            End If
        Next cel
    End If
Next ws
Range(Cells(1, 1), Cells(65536, 1).End(xlUp)).NumberFormat = "dd-mm-yyyy"
wsOld.Activate
End Sub

Now if you have already gathered all the dates into column E of the active worksheet, then you can simplify the macro like this:

Sub DateConversion()
Dim cel As Range
Dim RgExp As Object
Dim temp As Variant
Dim str As String
Dim i As Long
Set RgExp = CreateObject("VBScript.RegExp")
RgExp.Pattern = "(\d{4})\x2Egada\s*\x22?(\d{2})\x2E?\x22?\s*([A-Za-z]+)"
On Error Resume Next
For Each cel In Range(Cells(2, 5), Cells(65536, 5).End(xlUp))
    If Not IsError(cel) Then
        If cel <> "" And RgExp.test(LCase(cel.Value)) Then
            str = RgExp.Replace(LCase(cel), "$2 $3 $1")
            temp = DateValue(str)
            i = i + 1
            If Err > 0 Then
                cel = str
                Err.Clear
            Else
                cel = temp
            End If
        End If
    End If
Next cel
Range(Cells(2, 5), Cells(65536, 5).End(xlUp)).NumberFormat = "dd-mm-yyyy"
End Sub

Brad

 

[selenus]

I tried ETID code: run "Transcribe_dates", then show form: "Enter the Column Letter" -> E, but got 'Run-time error '1004' A debug show the following(yellow):
--------------------------------------------------
Selection.Replace What:=mon_text(m), Replacement:=mon_val(m), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
------------------------------------------------------

When I tried Byundt code, it got something like this:

05 janvaris 2004
06 janv 2004?ris
08 janv 2004?ris
08 janv 2004?ris
15 janv 2004?ris
19 janv 2004?ris
20 janv 2004?ris
20 janv 2004?ris
21 janv 2004?ris
28 janv 2004?ris
29 janv 2004?ris
30 janv 2004?ris
02 febru 2004?ris
02 febru 2004?ris
03 febru 2004?ris
09 febru 2004?ris
09 febru 2004?ris
09 febru 2004?ris
12 febru 2004?ris
03 j 2004?nij?
10 j 2004?nijs
15 j 2004?nijs
05 j 2004?nijs
16 j 2004?lijs
------------------------

 

[byundt]

Selenus,

Could you confirm the following:
1) That your Excel can handle the date conversion if everything is formatted correctly? Specifically, after you convert the Engish function names and format string into your language, this worksheet formula ought to return 25-03-2003
=TEXT(DATEVALUE("25 marta 2003"),"dd-mm-yyyy")

2) That your VBA date conversion also works. Put the following statement in the immediate window, and it should display a message box with 25-03-2003

MsgBox(Format(DateValue("25 marta 2003"),"dd-mm-yyyy"))

Brad

 

[PHV]

And what about something like this ?
Sub DateConversion()
Dim c As Range, l As Long, tmpArr
l = Range("E:E").Find( _
What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
For Each c In Range("E2:E" & l)
tmpArr = Split(c.Text)
If UBound(tmpArr) = 2 Then
tmpArr(1) = Replace(Replace(tmpArr(1), Chr(34), ""), ".", "")
Select Case LCase(Left(tmpArr(2), 3))
Case "jan": tmpArr(2) = "01"
Case "feb": tmpArr(2) = "02"
Case "mar": tmpArr(2) = "03"
Case "apr": tmpArr(2) = "04"
Case "mai": tmpArr(2) = "05"
Case "jun": tmpArr(2) = "06"
Case "jul": tmpArr(2) = "07"
Case "aug": tmpArr(2) = "08"
Case "sep": tmpArr(2) = "09"
Case "okt": tmpArr(2) = "10"
Case "nov": tmpArr(2) = "11"
Case "dec": tmpArr(2) = "12"
End Select
c.Value = DateSerial(Left(tmpArr(0), 4), tmpArr(2), tmpArr(1))
End If
Next
Columns("E:E").NumberFormat = "dd-mm-yyyy"
End Sub

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[selenus]

PHV macro: I got 'Run-time error 13' 'Type mismatch'

c.Value = DateSerial(Left(tmpArr(0), 4), tmpArr(2), tmpArr(1))

Though, some data was converted, some -not.

converted OK example:

2003.gada "10." Mart?
2003.gada "11." Mart?
2003.gada "13." Marts
2003.gada "14." Marts
2003.gada "18." Marts
---------------------------

not converted:

2003.gada "25."Febru?ris
2003.gada "03."Marts
2003.gada "18 " Marts
2003.gada "01."apr?l?

2003.gada "06." Majs
2003.gada "06." Maijs
2003.gada "08" Maijs
2003.gada "09." Maijs
2003.gada "13." Maijs
2003.gada "21." Maijs
2003.gada "23." Maijs
2003.gada "27." Maijs

and so on

My data string may differs a little, i.e. commas, tabs


Selenus

 

[byundt]

Selenus,
Since you don't use a Latvian version of Excel, I needed to change my approach. Most of the Latvian months have the same 3 initials as English months--the exceptions being May and October. In addition, I needed to convert the ?(Unicode 363) to a u so June and July could be recognized. The revised code becomes:

Sub DateConversion()
Dim cel As Range
Dim RgExp As Object
Dim temp As Variant
Dim str As String
Dim i As Long
Set RgExp = CreateObject("VBScript.RegExp")
RgExp.Pattern = "(\d{4})\.\s?gada\s*\x22?(\d{2})[\.|\s]?\x22?\s*(.{3}).*"
On Error Resume Next
For Each cel In Range(Cells(2, 5), Cells(65536, 5).End(xlUp))
    If Not IsError(cel) Then
        If cel <> "" And RgExp.test(LCase(cel.Value)) Then
            str = RgExp.Replace(LCase(cel), "$2 $3 $1")
            str = Replace(str, "okt", "oct")    'Fix October
            str = Replace(str, ChrW(363), "u")  'Fix June, July
            str = Replace(str, "mai", "may")    'Fix May
            str = Replace(str, "maj", "may")    'Fix May misspelling
            temp = DateValue(str)
            i = i + 1
            If Err > 0 Then
                cel = str
                Err.Clear
            Else
                cel = temp
            End If
        End If
    End If
Next cel
Range(Cells(2, 5), Cells(65536, 5).End(xlUp)).NumberFormat = "dd-mm-yyyy"
End Sub

Brad

 

[selenus]

Brad,

but, does its possible use VBAjedi approach offered (top of thread)for month definition :just to rely on the first three letters of the word to determine the month?( I'd would like to avoid using VBScript)

Selenus

 

[byundt]

Selenus,
That's what my code is doing--relying on the first three letters of the month to identify it.

I used VBScript to get the date string properly formatted. I'll admit that the RgExp.Pattern statement looks really arcane. And it took a lot of time for me to develop it. But you had a lot of variation in your sample data--with spaces, quotes and periods there sometimes and other times not, and that one pattern deals with it all.

Because VBScript is added to your computer when you install Internet Explorer 5 or later, you can incorporate its objects in VBA code. The program user doesn't need to take any special steps. I've tested it in Excel 97 through 2003.
Brad