Same value in 2 files are different when compared VBA - string

I'm trying to compared 2 different excel files that contain same fields sometimes.
When I find it (by watch view) the vba say they are different...
Dim ctrl As Integer
Sub btnCheck_Click()
Dim lot As Workbook, pr As Workbook, this As Workbook
Dim a As Variant, b As Variant
Dim i As Integer, j As Integer
Dim passed As Boolean
Set this = Application.ThisWorkbook
this.Worksheets(1).Range("C5:J1000").ClearContents
Application.ScreenUpdating = False
a = ThisWorkbook.Path & "\" & "A.xlsx"
Set lot = Application.Workbooks.Open(a, False, False)
b = ThisWorkbook.Path & "\" & "B.xls"
Set pr = Application.Workbooks.Open(b, False, False)
i = 2
x = 2
lin = 2
Do Until lot.Worksheets(1).Range("A" & i).Value = ""
passed = False
j = 2
Do Until pr.Worksheets(1).Range("A" & j).Value = ""
If lot.Worksheets(1).Range("B" & i).Value = pr.Worksheets(1).Range("C" & j).Value Then
passed = True
this.Worksheets(1).Range("D" & x).Value = "ok"
x = x + 2
End If
j = j + 1
Loop
i = i + 1
Loop
lot.Close True
Set lot = Nothing
pr.Close True
Set pr = Nothing
Application.ScreenUpdating = True
End Sub
Function CleanStr(ByVal str As String)
CleanStr = Replace(str, Chr$(32), "")
End Function
The files A and B are linked at the comments bellow.

A and B are not the same. One ends in a space (ASCII 32) while the other ends in a non-breaking space (ASCII 160). Invisible is invisible to our eyes, but to a computer, ASCII(32)<>ASCII(160)
You can verify this by adding this function to your macro:
Function strings2ascii(ByVal str1 As String, str2 As String)
Dim x As Integer
Dim intStrLen As Integer
Dim strResult As String
If Len(str1) > Len(str2) Then
intStrLen = Len(str1)
Else
intStrLen = Len(str2)
End If
For x = 1 To Len(str1)
strResult = strResult & Asc(Mid(str1, x, 1)) & ":" & Asc(Mid(str2, x, 1)) & vbCrLf
Next
MsgBox strResult
End Function
Now call this function in your loop:
Do Until pr.Worksheets(1).Range("A" & j).Value = ""
strings2ascii lot.Worksheets(1).Range("B" & i).Value, pr.Worksheets(1).Range("C" & j).Value
If lot.Worksheets(1).Range("B" & i).Value = pr.Worksheets(1).Range("C" & j).Value Then
You will immediately see that they never match because they are not the same. Here is a similar SO post regarding ASCII 160 errors: Trouble replacing Chr(160) with VBA in excel

Not sure if this will answer the question but that can't stand in a comment :)
I would say that some cells contains invisible chars that arent spaces.
Here's a recursive function that remove them from a string :
Function CleanString(StrIn As String) As String
' "Cleans" a string by removing embedded control (non-printable)
' characters, including carriage returns and linefeeds.
' Does not remove special characters like symbols, international
' characters, etc. This function runs recursively, each call
' removing one embedded character
Dim iCh As Integer
CleanString = StrIn
For iCh = 1 To Len(StrIn)
If Asc(Mid(StrIn, iCh, 1)) < 32 Then
'remove special character
CleanString = Left(StrIn, iCh - 1) & CleanString(Mid(StrIn, iCh + 1))
Exit Function
End If
Next iCh
End Function
Give it a try like this :
Do Until b.Worksheets(1).Range("A" & j).Value = ""
sa = CleanString(a.Worksheets(1).Range("B" & i).Value)
sb = CleanString(b.Worksheets(1).Range("C" & j).Value)
oa = CleanString(a.Worksheets(1).Range("E" & i).Value)
ob = CleanString(b.Worksheets(1).Range("F" & j).Value)
If StrComp(sa, sb) = 0 And StrComp(oa, ob) = 0 Then
Passed = True

Related

Excel VBA script to output TSV is giving leading and trailing double quotes, how can I remove them

Sub ExportDataTSV()
Dim BCS As Worksheet
Dim Ctrl As Worksheet
Dim ws As Worksheet
Dim FName As String
Dim insertValues As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set BCS = ThisWorkbook.Sheets(Sheet2.Name)
Set Ctrl = ThisWorkbook.Sheets(Sheet1.Name)
fileDate = Year(Now) & "_" & Month(Now) & "_" & Day(Now) & "_" & Format(Now, "hh")
#If Mac Then
NameFolder = "documents folder"
If Int(Val(Application.Version)) > 14 Then
'You run Mac Excel 2016
folder = _
MacScript("return POSIX path of (path to " & NameFolder & ") as string")
'Replace line needed for the special folders Home and documents
folder = _
Replace(SpecialFolder, "/Library/Containers/com.microsoft.Excel/Data", "")
Else
'You run Mac Excel 2011
folder = MacScript("return (path to " & NameFolder & ") as string")
End If
FName = folder & ":bcs_output.txt"
#Else
folder = Environ$("userprofile")
FName = folder & "\Documents\bcs_output_" & fileDate & ".txt"
#End If
If Ctrl.Range("D9") = "" Or Ctrl.Range("D10") = "" Then
MsgBox "Please enter the Scenario Year and Scenario you wish to save and click again", vbOKOnly
Exit Sub
End If
Ctrl.Range("D9").Copy
BCS.Range("AS2").PasteSpecial Paste:=xlPasteValues
Ctrl.Range("D10").Copy
BCS.Range("AT2").PasteSpecial Paste:=xlPasteValues
Call ClearFile(FName)
With BCS
.AutoFilter.ShowAllData
numrows = .Cells(.Rows.Count, 1).End(xlUp).Row
numcol = .Cells(2, Columns.Count).End(xlToLeft).Column
.Range("AS1").Value = "scenario_year"
.Range("AS2:AS" & numrows).FillDown
.Range("AT1").Value = "scenario"
.Range("AT2:AT" & numrows).FillDown
.Range("AU1").Value = "save_date"
.Range("AU2").Formula = "=NOW()"
.Range("AU2:AU" & numrows).FillDown
.Range("AU2:AU" & numrows).NumberFormat = "yyyy-mm-dd hh:mm"
For x = 2 To numrows
Set rng1 = .Range("A" & x & ":R" & x)
Set rng2 = .Range("AC" & x & ":AF" & x)
Set rng3 = .Range("AH" & x & ":AK" & x)
Set rng4 = .Range("AN" & x & ":AO" & x)
Set rng5 = .Range("AS" & x & ":AU" & x)
Set Data = Union(rng1, rng2, rng3, rng4, rng5)
insertValues = Join2D(ToArray(Data), Chr(9))
Call ConvertText(FName, insertValues)
Next x
End With
With BCS
.Activate
.Range("A1").Select
End With
Ctrl.Activate
Application.ScreenUpdating = True
MsgBox "Cluster Data saved to " & FName & ", please upload the file here: https://awsfinbi.corp.amazon.com/s/dcgs_abv/submit", vbOKOnly
Application.EnableEvents = True
End Sub
Function ToArray(rng) As Variant()
Dim arr() As Variant, r As Long, nr As Long
Dim ar As Range, c As Range, cnum As Long, rnum As Long
Dim col As Range
nr = rng.Areas(1).Rows.Count
ReDim arr(1 To nr, 1 To rng.Cells.Count / nr)
cnum = 0
For Each ar In rng.Areas
For Each col In ar.Columns
cnum = cnum + 1
rnum = 1
For Each c In col.Cells
arr(rnum, cnum) = c.Value
rnum = rnum + 1
Next c
Next col
Next ar
ToArray = arr
End Function
Public Function Join2D(ByVal vArray As Variant, Optional ByVal sWordDelim As String = " ", Optional ByVal sLineDelim As String = vbNewLine) As String
Dim i As Long, j As Long
Dim aReturn() As String
Dim aLine() As String
ReDim aReturn(LBound(vArray, 1) To UBound(vArray, 1))
ReDim aLine(LBound(vArray, 2) To UBound(vArray, 2))
For i = LBound(vArray, 1) To UBound(vArray, 1)
For j = LBound(vArray, 2) To UBound(vArray, 2)
'Put the current line into a 1d array
aLine(j) = vArray(i, j)
Next j
'Join the current line into a 1d array
aReturn(i) = Join(aLine, sWordDelim)
Next i
Join2D = Join(aReturn, sLineDelim)
End Function
Public Function ClearFile(myfile)
Open myfile For Output As #1: Close #1
End Function
Public Function ConvertText(myfile As String, strTxt As String)
Open myfile For Append As #1
Write #1, strTxt
Close #1
End Function
The above functions are what I have strung together from various SO post and googles. It works to a large degree, but when it creates the txt file with the tab delimiter it gives an output where in the text separator is a single quote. However, the entire line is wrapped in double quotes. So the output looks something like "'Field1'\t'Field2'\t'Field3'" . That is not a valid TSV format for loading into a database like Redshift due to the double quotes. I need the double quotes to not be in the file, can anyone identify why it is adding them? Is there a way to prevent it or a better way to create a tab delimited file output for loading to Redshift?
For further information it MUST be a txt with tab delimiter, I have no control over that requirement.
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/writestatement
Unlike the Print # statement, the Write # statement inserts commas
between items and quotation marks around strings as they are written
to the file. You don't have to put explicit delimiters in the list.
Write # inserts a newline character, that is, a carriage
return-linefeed (Chr(13) + Chr(10) ), after it has written the final
character in outputlist to the file.
To not add quotes switch to Print:
Print #1, strTxt

Trim Function does not remove the spaces - VBA Excel

I've seen a few topics related to this question, unfortunately non of them helped. Trim simply doesn't remove the spaces neither before or after...
Macro should be going through column "F" ad trim all the edges, currently id does go through the column and with the help of MsgBox I saw that it get's all the values in the cells correctly, yet the actual trimming doesn't work.
Sub trimAllTrends()
Dim i As Integer
Dim allInLastRow As Long
Dim allInWs As Worksheet
Dim myString As String
Set allInWs = ThisWorkbook.Worksheets("All Trends")
allInLastRow = allInWs.Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To allInLastRow
myString = allInWs.Cells(i, 6).Value
'MsgBox (myString)
'WorksheetFunction.Trim (allInWs.Cells(i, 6))
'allInWs.Cells(i, 6).Value = LTrim(allInWs.Cells(i, 6).Value)
'.Cells(i, "F").Value = Application.Trim(.Cells(i, "F").Value)
WorksheetFunction.Trim (myString)
Next i
End Sub
Any help is much appreciated!
Thank you in advance!
I have to say I've found the Trim() function a bit limited, especially with data imported from a word processing or page design application. So the points everyone makes in the comments are all good ones.
If it's of interest to you, I use my own TrimWhitespace() function. There are doubtless quicker ways of doing it, but I find this one suits my purposes:
Public Function TrimWhitespace(txt As String) As String
Dim i As Long, j As Long, c As Long
Dim startPos As Long, endPos As Long
Dim whitespaces As Variant
Dim isWhitespace As Boolean
' List of whitespace characters.
whitespaces = Array( _
&H9, &HA, &HB, &HC, &HD, &H20, &H85, &HA0, _
&H1680, &H2000, &H2001, &H2002, &H2003, &H2004, &H2005, &H2006, _
&H2007, &H2008, &H2009, &H200A, &H2028, &H2029, &H202F, &H205F, _
&H3000, &H180E, &H200B, &H200C, &H200D, &H2060, &HFEFF)
' Find the first non-whitespace.
For i = 1 To Len(txt)
c = Asc(Mid(txt, i, 1))
isWhitespace = False
For j = LBound(whitespaces) To UBound(whitespaces)
If c = whitespaces(j) Then
isWhitespace = True
Exit For
End If
Next
If Not isWhitespace Then
startPos = i
Exit For
End If
Next
' If there's no start position, return an empty string.
If startPos = 0 Then Exit Function
' Find the last non-whitespace.
For i = Len(txt) To startPos Step -1
c = Asc(Mid(txt, i, 1))
isWhitespace = False
For j = LBound(whitespaces) To UBound(whitespaces)
If c = whitespaces(j) Then
isWhitespace = True
Exit For
End If
Next
If Not isWhitespace Then
endPos = i
Exit For
End If
Next
TrimWhitespace = Mid(txt, startPos, endPos - startPos + 1)
End Function
Here's some testing code to demonstrate it:
Public Sub RunMe()
Dim txt1 As String, txt2 As String
txt1 = Chr(32) & Chr(160) & Chr(9) & "abc" & Chr(32) & Chr(160) & Chr(9)
txt2 = Chr(32) & Chr(160) & Chr(9) & "xyz" & Chr(32) & Chr(160) & Chr(9)
txt1 = Trim(txt1)
txt2 = TrimWhitespace(txt2)
Debug.Print "TRIM RESULTS"
Debug.Print "============"
Debug.Print "Trim()"
Debug.Print "------"
Debug.Print "Trimmed: |" & txt1 & "|"
Debug.Print "Desired: |abc|"
Debug.Print
Debug.Print "TrimWhitespace()"
Debug.Print "------------------------"
Debug.Print "Trimmed: |" & txt2 & "|"
Debug.Print "Desired: |xyz|"
End Sub

mixing subscript in a string

in a VBA excel macro I am using, I have the following code:
For k = MinDeg To MaxDeg
OutputStr = Trim(OutputStr & "a" & Str(k) & " = " & _
Str(MyCoe) & " ± " & _
Str(MyErr) & Chr(10))
Next k
Where "MyCoe" and "MyErr" are given numbers, and "minDeg" and "MaxDeg" are integers.
My question is:
How can I make "Str(k)" appear in the outputstr as subscript text?
If Unicode is available in your environment, another option would be to use the subscripted Unicode characters for Str(K). Making some modifications to Gary's Student code so as to get output in A1:
Option Explicit
Sub foo()
Dim K As Long
Const MinDeg As Long = 10
Const MaxDeg As Long = 13
Dim sK As String, I As Long
Const MyCoe As Long = 3
Const MyErr As Long = 5
Dim OutPutStr As String
For K = MinDeg To MaxDeg
sK = ""
For I = 1 To Len(CStr(K))
sK = sK & ChrW(832 & Mid(CStr(K), I, 1))
Next I
OutPutStr = Trim(OutPutStr & "a" & sK & " = " & _
Str(MyCoe) & " ± " & _
Str(MyErr) & Chr(10))
Next K
Cells(1, 1) = OutPutStr
End Sub
Note that the subscripted values also appear in the formula bar.
First I run this simple mod to your code:
Sub WhatEverr()
mindeg = 10
maxdeg = 13
mycoe = 3
myerr = 5
For k = mindeg To maxdeg
outputstr = Trim(outputstr & "a" & Str(k) & " = " & _
Str(mycoe) & " ± " & _
Str(myerr) & Chr(10))
Next k
Range("A1").Value = outputstr
End Sub
to get this in A1:
Then I run:
Sub formatcell()
Dim i As Long, L As Long, rng As Range
Dim s As String
Set rng = Range("A1")
s = rng.Value
L = Len(s)
For i = 1 To L
ch = Mid(s, i, 1)
If ch = "a" Then
rng.Characters(Start:=i + 2, Length:=2).Font.Subscript = True
End If
Next i
End Sub
To apply the format:
In Excel, this type of character formatting is a property of the Range object. You do not build it into the string like you would in HTML.

String operation VBA Excel

I am struggling with the following problem.
I want to do following operations on Input Col A and produce output in col B:
1.Remove Duplicates if any ( It was easy and completed )
2.Remove Leading and/or Trailing spaces from the string (It was easy as well and it's done )
3.COLLECT THE DIFFERENT TRANSLATIONS OF A WORD IN SAME CELL - AVOID DUPLICATES ( It's hard and I don't know how to proceed with this problem )
To understand this point have a look at input/output example.
Input:
A
 absolution
 absolution
 absolutism
 absolutism, absolute rule
  absolutist   
  absolutist   
 absorb
 absorb
 absorb, bind
 absorb, take up
 absorb
 absorb, imbibe, take up
 absorb, sorb
 absorb, take up
 absorb, take up
 absorb, imbibe
 absorb
 absorb
 absorber
 absorber
 absorber
Output:
col B
absolution
absolutism, absolute rule
absolutist
absorb, bind, imbibe, take up, sorb
absorber
I tried with the following code but I am stuck on the third point/step
Option Explicit
Sub StrMac()
Dim wk As Worksheet
Dim i, j, l, m As Long
Dim strc, strd, fstrc, fstrd As String
Dim FinalRowC, FinalRowD As Long
Set wk = Sheet1
wk.Columns(1).Copy Destination:=wk.Columns(3)
wk.Columns(2).Copy Destination:=wk.Columns(4)
wk.Range("$C:$C").RemoveDuplicates Columns:=1, Header:=xlNo
wk.Range("$D:$D").RemoveDuplicates Columns:=1, Header:=xlNo
FinalRowC = wk.Range("C1048576").End(xlUp).Row
FinalRowD = wk.Range("D1048576").End(xlUp).Row
If FinalRowC >= FinalRowD Then
j = FinalRowC
Else
j = FinalRowD
End If
For i = 1 To j
If wk.Range("C" & i).Text <> "" Then
strc = wk.Range("C" & i).Text
strc = Replace(strc, Chr(160), "")
strc = Application.WorksheetFunction.Trim(strc)
wk.Range("C" & i).Value = strc
Else: End If
If wk.Range("D" & i).Text <> "" Then
strd = wk.Range("D" & i).Text
strd = Replace(strd, Chr(160), "")
strd = Application.WorksheetFunction.Trim(strd)
wk.Range("D" & i).Value = strd
Else: End If
Next i
Dim Cet, Det, Fet, Met, s As Variant
Dim newstr
Dim pos, cos As Long
s = 1
For i = 1 To j
If wk.Range("D" & i).Text <> "" Then
l = 2
strd = wk.Range("D" & i).Text
newstr = strd
For m = i + 1 To j
pos = 1100
cos = 2300
fstrd = wk.Range("D" & m).Text
cos = InStr(1, fstrd, ",")
pos = InStr(1, fstrd, strd, vbTextCompare)
If wk.Range("D" & m).Text <> "" And Len(fstrd) > Len(strd) And m <= j And cos <> 2300 And pos = 1 Then
l = 5
newstr = newstr & "," & fstrd
wk.Range("D" & m) = ""
Else: End If
Next m
wk.Range("E" & s) = newstr
s = s + 1
Else: End If
Next i
End Sub
Assuming your input is column A and you want the output in column B (as stated in your question), the following should work for you:
Sub tgr()
Dim ws As Worksheet
Dim rData As Range
Dim aData As Variant
Dim vData As Variant
Dim vWord As Variant
Dim aResults() As String
Dim sUnq As String
Dim i As Long
Set ws = ActiveWorkbook.Sheets("Sheet1")
Set rData = ws.Range("A1", ws.Cells(Rows.Count, "A").End(xlUp))
If rData.Cells.Count = 1 Then
'Only 1 cell in the range, check if it's no blank and output it's text
If Len(Trim(rData.Text)) > 0 Then ws.Range("B1").Value = WorksheetFunction.Trim(rData.Text)
Else
'Remove any extra spaces and sort the data
With rData
.Value = Evaluate("index(trim(" & .Address(external:=True) & "),)")
.Sort .Cells, xlAscending, Header:=xlNo
End With
aData = rData.Value 'Load all values in range to array
ReDim aResults(1 To rData.Cells.Count, 1 To 1) 'Ready the results array
For Each vData In aData
'Get only unique words
If InStr(1, vData, ",", vbTextCompare) = 0 Then
If InStr(1, "," & sUnq & ",", "," & vData, vbTextCompare) = 0 Then
sUnq = sUnq & "," & vData
If i > 0 Then aResults(i, 1) = Replace(aResults(i, 1), ",", ", ")
i = i + 1
aResults(i, 1) = vData
End If
Else
'Add unique different translations for the word
For Each vWord In Split(vData, ",")
If InStr(1, "," & aResults(i, 1) & ",", "," & Trim(vWord) & ",", vbTextCompare) = 0 Then
aResults(i, 1) = aResults(i, 1) & "," & Trim(vWord)
End If
Next vWord
End If
Next vData
End If
'Output results
If i > 0 Then ws.Range("B1").Resize(i).Value = aResults
End Sub

How to scrub through a string to match a date

So I have built a workbook for validation and publishing sets of other workbooks/reports out to another location. Part of the process is for the user to enter a date value into a cell, and that is checked for within the reports the user has listed.
Date formatting doesn't matter because I am doing a date type to date type comparison in my validation function.
Basically:
if CDate(UserVal) = CDate(ValFromString) then
'do stuff
end if
The other common occurrence is the date has always been at the end of the string in the compared cell.
Example:
Current 52 Weeks Ending 04/10/15
Cur 52 Weeks Apr 4, 2015
Current 52 WE 4-Apr-15
No matter what format the user inputs into the validation cell, I just keep stripping from the right until isdate pops true.
I know I have been lucky in this setup, with the date always being at the end. I've now run into two instances that do not work.
CURRENT 12 WEEKS (4 WEEKS ENDING 04/11/15)
4 WE 04/11/2015 Current 12
In the first, the parenthesis breaks my right() stripping. In the second, the date is in the middle. The format of the date value differs from report to report, so I cannot do a instr(1, String, cstr(UserVal)) to accomplish the check. The location of the date is not set in stone either, as it could be at the end, beginning, or anywhere in the middle of the string.
Short way of putting it, is there an easy way to scan a string for a specified date value, agnostic of format?
Here is my feeble attempt :D
This will match a wide range of date formats
Hope this helps
Sub Sample()
Dim MyAr(1 To 5) As String, frmt As String
Dim FrmtAr, Ret
Dim i As Long, j As Long
MyAr(1) = "(This 01 has 04/10/15 in it)"
MyAr(2) = "This 04/10/2015"
MyAr(3) = "4-Apr-15 is a Sample date"
MyAr(4) = "(Apr 4, 2015) is another sample date"
MyAr(5) = "How about ((Feb 24 2012)) this?"
'~~> Various date formats
'~~> YYYY (/????) grouped together. Will search for this first
frmt = "??/??/????|?/??/????|??/?/????|??-??-????|"
frmt = frmt & "?-??-????|??-?-????|??? ?? ????|??? ? ????|"
frmt = frmt & "?-???-????|???-??-????|???-?-????|"
frmt = frmt & "??? ??, ????|??? ?, ????|"
'~~> YY (??) grouped after. Will search for this later
frmt = frmt & "??-???-??|?-???-??|??/??/??|?/??/??|??/?/??|"
frmt = frmt & "??-??-??|?-??-??|??-?-??|???-??-??|???-?-??|"
frmt = frmt & "|??? ?? ??|??? ? ??|??? ??, ??|??? ?, ??|"
FrmtAr = Split(frmt, "|")
For i = LBound(MyAr) To UBound(MyAr)
For j = 0 To UBound(FrmtAr)
'Something like =MID(A1,SEARCH("??/??/??",A1,1),8)
Expr = "=MID(" & Chr(34) & MyAr(i) & Chr(34) & ",SEARCH(" & _
Chr(34) & Trim(FrmtAr(j)) & Chr(34) & _
"," & Chr(34) & MyAr(i) & Chr(34) & ",1)," _
& Len(Trim(FrmtAr(j))) & ")"
Ret = Application.Evaluate(Expr)
If Not IsError(Ret) Then
If IsDate(Ret) Then
Debug.Print Ret
Exit For
End If
End If
Next j
Next i
End Sub
Output
EDIT
You can also use this as an Excel function
Paste this in a module
Public Function ExtractDate(rng As Range) As String
Dim frmt As String
Dim FrmtAr, Ret
Dim j As Long
ExtractDate = "No Date Found"
'~~> Various date formats
'~~> YYYY (/????) grouped together. Will search for this first
frmt = "??/??/????|?/??/????|??/?/????|??-??-????|"
frmt = frmt & "?-??-????|??-?-????|??? ?? ????|??? ? ????|"
frmt = frmt & "?-???-????|???-??-????|???-?-????|"
frmt = frmt & "??? ??, ????|??? ?, ????|"
'~~> YY (??) grouped after. Will search for this later
frmt = frmt & "??-???-??|?-???-??|??/??/??|?/??/??|??/?/??|"
frmt = frmt & "??-??-??|?-??-??|??-?-??|???-??-??|???-?-??|"
frmt = frmt & "|??? ?? ??|??? ? ??|??? ??, ??|??? ?, ??|"
FrmtAr = Split(frmt, "|")
For j = 0 To UBound(FrmtAr)
'Something like =MID(A1,SEARCH("??/??/??",A1,1),8)
Expr = "=MID(" & Chr(34) & rng.Value & Chr(34) & ",SEARCH(" & _
Chr(34) & Trim(FrmtAr(j)) & Chr(34) & _
"," & Chr(34) & rng.Value & Chr(34) & ",1)," _
& Len(Trim(FrmtAr(j))) & ")"
Ret = Application.Evaluate(Expr)
If Not IsError(Ret) Then
If IsDate(Ret) Then
ExtractDate = Ret
Exit For
End If
End If
Next j
End Function
Note: I am still working on a RegEx version which will be pretty much shorter than this...
Edit: As promised! I am sure it make me made more perfect but now I can't spend more time on this :)
RegEx Version
Sub Sample()
Dim MyAr(1 To 5) As String
MyAr(1) = "(This 01 has (04/10/15) in it)"
MyAr(2) = "This 04/10/2015"
MyAr(3) = "4-Apr-15 is a smaple date"
MyAr(4) = "(Apr 4, 2015) is another sample date"
MyAr(5) = "How about ((Feb 24 2012)) this?"
For i = 1 To 5
Debug.Print DateExtract(MyAr(i))
Next i
End Sub
Function DateExtract(s As String) As String
Dim a As String, b As String, c As String
Dim sPattern As String
sPattern = "\b(jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec)"
sPattern = sPattern & "\s(\d\d?),?\s+(\d{2,4})|(\d\d?)[\s-]("
sPattern = sPattern & "jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec"
sPattern = sPattern & ")[\s-,]\s?(\d{2,4})|(\d\d?)[-/](\d\d?)[-/](\d{2,4})\b"
With CreateObject("VBScript.RegExp")
.Global = False
.IgnoreCase = True
.Pattern = sPattern
If .Test(s) Then
Dim matches
Set matches = .Execute(s)
With matches(0)
a = .SubMatches(0) & .SubMatches(3) & .SubMatches(6)
b = .SubMatches(1) & .SubMatches(4) & .SubMatches(7)
c = .SubMatches(2) & .SubMatches(5) & .SubMatches(8)
DateExtract = a & " " & b & " " & c
End With
End If
End With
End Function
The following will find a date if it is there, but it may not be the date you want:
Sub INeedADate()
Dim st As String, L As Long, i As Long, j As Long
st = ActiveCell.Text
L = Len(st)
For i = 1 To L - 1
For j = 1 To L
st2 = Mid(st, i, j)
If IsDate(st2) Then
MsgBox CDate(st2)
Exit Sub
End If
Next j
Next i
End Sub
The routine generates all properly sequenced sub-strings of a string and tests each one for IsDate()
The problem is that for:
Current 52 Weeks Ending 04/10/15
It finds the sub-string:
04/1
first - which is a valid date!!
Do you want ALL valid dates within the string ???
EDIT#1:
The solution is to just run the length part of the Mid() function backwards:
Sub INeedADate()
Dim st As String, L As Long, i As Long, j As Long
st = ActiveCell.Text
L = Len(st)
For i = 1 To L - 1
For j = L To 1 Step -1
st2 = Mid(st, i, j)
If IsDate(st2) Then
MsgBox CDate(st2)
Exit Sub
End If
Next j
Next i
End Sub

Resources