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.
Related
I have been trying to Concatenate two Columns directly from the Table1. But i really do not know how. I have tried and make below code.
But I have been creating first 2 helping Column in in "DI" and "DJ" to make this thing work.
I do not want to use these two helping columns directly wants the concatenate result in "DK2"
All help will be appreciaed.
Dim O As String
Dim P As String
O = "Milestone"
P = "Task"
Sheet1.Range("Table1[" & O & "]").Copy
Sheet2.Range("DI2").PasteSpecial xlPasteValues
Sheet1.Range("Table1[" & P & "]").Copy
Sheet2.Range("DJ2").PasteSpecial xlPasteValues
For i = 2 To Cells(Rows.Count, "DH").End(xlUp).Row
Sheet2.Cells(i, "DK").Value = Sheet2.Cells(i, "DI").Value & "" & Sheet2.Cells(i, "DJ").Value
Next i
Here is the example Picture
Try this.
Range("DK2").Resize(Sheet2.ListObjects("Table1").ListRows.Count) = Application.Evaluate("Table1[Milestone]&Table1[Task]")
EDIT: I've seen #norie's answer and it is simpler and more efficient than mine. I'll keep my answer here for anyone who is curious, but I recommend using his solution.
The trick is to use =INDEX(YOUR_TABLE[YOUR_COLUMN]], YOUR_ROW_STARTING_FROM_1) in order to obtain the cell contents that you needed.
Here you are your code edited:
Original
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").Value = Application.Evaluate("INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")")
Next i
Optimized
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").Value = Application.Evaluate("INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")")
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
Optimized using only Formulas (this performs better that the others)
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").FormulaR1C1 = "=INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")"
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
Optimized using Formulas and then converting back to values
Dim O As String
Dim P As String
Dim i As Integer
O = "Milestone"
P = "Task"
' Disable formula recalculation while trying to add our data to increase performance
Application.Calculation = xlManual
' Disable screen updating while trying to add our data to improve performance
Application.ScreenUpdating = False
For i = 1 To Application.Evaluate("ROWS(Table1[" & O & "])")
Sheet2.Cells(i, "DK").FormulaR1C1 = "=INDEX(Table1[" & O & "], " & i & ") & INDEX(Table1[" & P & "], " & i & ")"
Next i
' Enable again formula's automatic evaluation.
Application.Calculation = xlAutomatic
' Enable again screen updating
Application.ScreenUpdating = True
' Convert from formulas to values
Range("DK:DK").Copy
Range("DK:DK").PasteSpecial xlPasteValues
This can be done directly in the worksheet by using the Index function
Reference first cell in the table: =INDEX(Table1,1,1)
Concatenate cell 1 and 2 values: =INDEX(Table1,1,1)&INDEX(Table1,1,2)
It gets slightly more complicated if you want to be able to copy formulae across or down as you need to reference the current cell location
Reference first cell in the table using offsets: =INDEX(Table1,ROW()-X,COLUMN()-Y) where X, Y (minus data location offsets) are the numerical row/column of the cell where you have placed the formula.
i.e. if placing the formula in E2 to reference Table1 cell(1,1) => =INDEX(Table1,ROW()-1,COLUMN()-4)
where Column E=> Offset 4, Row 2 => Offset 1
or: =INDEX(Table1,ROW()-ROW($E$2)+1,COLUMN()-COLUMN($E$2)+1)
You can now autofill the formula down or across
Concatenate List Columns
With your amount of data both solutions may seem equally efficient. I've tested it with a million rows of random numbers from 1 to 1000, and the first solution took about 3.5 seconds, while the second took about 5.5 seconds on my machine. The first solution is just a more elaborate version of norie's answer.
In this solution, you can add more columns (headers) and use a delimiter. While adding more columns the difference in the efficiencies will become more apparent, while when adding more characters to the delimiter, the efficiencies will decrease seemingly equally.
The Code
Option Explicit
Sub concatListColumnsEvaluate()
Dim dTime As Double: dTime = Timer
' Define constants.
Const TableName As String = "Table1"
Const HeadersList As String = "Milestone,Task"
Const dFirst As String = "D2"
Const Delimiter As String = ""
' Determine table rows count.
Dim rCount As Long: rCount = Sheet1.ListObjects(TableName).ListRows.Count
' Create Evaluate Expression String.
Dim Headers() As String: Headers = Split(HeadersList, ",")
Dim tUpper As Long: tUpper = UBound(Headers)
Dim evString As String
Dim t As Long
If Len(Delimiter) = 0 Then
For t = 0 To tUpper
evString = evString & TableName & "[" & Headers(t) & "]" & "&"
Next t
evString = Left(evString, Len(evString) - 1)
Else
For t = 0 To tUpper
evString = evString & TableName & "[" & Headers(t) & "]" & "&""" _
& Delimiter & """&"
Next t
evString = Left(evString, Len(evString) - Len(Delimiter) - 4)
End If
' Write values to Destination Range.
Sheet2.Range(dFirst).Resize(rCount).Value = Application.Evaluate(evString)
Debug.Print Timer - dTime
End Sub
Sub concatListColumnsArrays()
Dim dTime As Double: dTime = Timer
' Define constants.
Const TableName As String = "Table1"
Const HeadersList As String = "Milestone,Task"
Const dFirst As String = "D2"
Const Delimiter As String = ""
' Write values from list columns to arrays of Data Array.
Dim Headers() As String: Headers = Split(HeadersList, ",")
Dim tUpper As Long: tUpper = UBound(Headers)
Dim Data As Variant: ReDim Data(0 To tUpper)
Dim t As Long
For t = 0 To tUpper
' Either...
Data(t) = Sheet1.Range(TableName & "[" & Headers(t) & "]").Value
' ... or:
'Data(t) = Sheet1.ListObjects(TableName) _
.ListColumns(Headers(t)).DataBodyRange.Value
Next t
' Concatenate values of arrays of Data Array in Result Array.
Dim rCount As Long: rCount = UBound(Data(0), 1)
Dim Result As Variant: ReDim Result(1 To rCount, 1 To 1)
Dim r As Long
If Len(Delimiter) = 0 Then
For r = 1 To rCount
For t = 0 To tUpper
Result(r, 1) = Result(r, 1) & Data(t)(r, 1)
Next t
Next r
Else
For r = 1 To rCount
For t = 0 To tUpper
Result(r, 1) = Result(r, 1) & Data(t)(r, 1) & Delimiter
Next t
Result(r, 1) = Left(Result(r, 1), Len(Result(r, 1)) _
- Len(Delimiter))
Next r
End If
' Write values from Result Array to Destination Range.
Sheet2.Range(dFirst).Resize(rCount).Value = Result
Debug.Print Timer - dTime
End Sub
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
I am doing an index match lookup in VBA and it works perfectly when normal numbers are used but when it's formatted as a percentages it does not work, it throws an error. How do I solve this?
Sub TOP10() 'doesnt work on percentages
Dim rngTestArea As Range
Dim i, j As Long
Dim MyResult As String
lastRow = ThisWorkbook.Worksheets("GEODISTRIBUTION").Range("C" & Rows.Count).End(xlUp).Row
Set rngTestArea = ThisWorkbook.Worksheets("GEODISTRIBUTION").Range("K11:K" & lastRow)
j = 0
For i = 1 To 10
j = Application.WorksheetFunction.Large(rngTestArea, i)
Location = Application.WorksheetFunction.Index(Sheets("GEODISTRIBUTION").Range("C11:C" & lastRow), Application.WorksheetFunction.Match(j, rngTestArea, 0), 1)
geodis = geodis & Location & " - " & j & ","
Next i
MsgBox geodis
End Sub
I couldn't duplicate your exact problem ... except that I couldn't get it to run with out declaring Location and geodis as Variant (I also pulled the match out to see what was going on there).
After that, I got it to run with percentages. Here are the values in K11:K25 that I tested with: (I didn't have your data, so I had to end my last row with 26 for testing.)
1
2
3
4
5
6
7
8
0.25
5
5800%
58
5
52
88
Here is what I used to debug your code that ran:
Sub TOP10() 'doesnt work on percentages
Dim rngTestArea As Range
Dim i, j As Integer
Dim MyResult As String
Dim Location As Variant
Dim geodis As Variant
Dim match As Variant
lastRow = ThisWorkbook.Worksheets("GEODISTRIBUTION").Range("C" & Rows.Count).End(xlUp).Row
lastRow = 26
Set rngTestArea = ThisWorkbook.Worksheets("GEODISTRIBUTION").Range("K11:K" & lastRow)
j = 0
Debug.Print rngTestArea.Address
For i = 1 To 10
Debug.Print "i: " & i
j = Application.WorksheetFunction.Large(rngTestArea, i)
Debug.Print "j: " & j
match = Application.WorksheetFunction.match(j, rngTestArea, 0)
Debug.Print "match: " & match
Location = Application.WorksheetFunction.Index(Sheets("GEODISTRIBUTION").Range("C11:C" & lastRow), match, 1)
Debug.Print "Location: " & Location
geodis = geodis & Location & " - " & j & ","
Debug.Print "geodis: " & geodis
Next i
Debug.Print geodis
'MsgBox geodis
End Sub
I placed the value 2.24101235446119% in cell K11, and a formula in cells below that: =K11-0.01 down to row 111 (plus values in column C to find the last row).
This code returned 1 for Location - I've changed j to a double, i as a long and declared a few missing variables. Other than that it's your exact code.
Sub TOP10() 'doesnt work on percentages
Dim rngTestArea As Range
Dim i As Long, j As Double
Dim MyResult As String
Dim lastrow As Long
Dim Location As Variant
Dim geodis As String
lastrow = ThisWorkbook.Worksheets("GEODISTRIBUTION").Range("C" & Rows.Count).End(xlUp).Row
Set rngTestArea = ThisWorkbook.Worksheets("GEODISTRIBUTION").Range("K11:K" & lastrow)
j = 0
For i = 1 To 10
j = Application.WorksheetFunction.Large(rngTestArea, i)
Location = Application.WorksheetFunction.Index(Sheets("GEODISTRIBUTION").Range("C11:C" & lastrow), Application.WorksheetFunction.Match(j, rngTestArea, 0), 1)
geodis = geodis & Location & " - " & j & ","
Next i
MsgBox geodis
End Sub
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
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