VBA Find & Replace Changes Date To US Format - excel

when I run find and replace through vba it changes my dates to us format. So I have a column of dates, but they are all prefixed with text that I want to remove (like so Invoice Date:dd/mm/yyyy). When I use Ctrl + F and replace manually, it's all great. Removes the text, the date remains in it's original format dd/mm/yyyy. However, when using vba to do this it changes the dates to mm/dd/yyyy if the the day is less than 12 (ie months in a year). I've tried a number of different methods to convert it but they all seem to have the same problem. Here is my latest failure...
Sub DateConvert()
Sheets("Sheet1").Select
Dim strValue As String
Dim RowCount As Integer
Dim x As Integer
Dim DateValue As Date
RowCount = WorksheetFunction.CountA(Range("C1", Range("C1").End(xlDown)))
For x = 2 To RowCount
'changes cell value to a string
strValue = Cells(x, 3).Value
'removes unwanted text
Cells(x, 3).Replace _
What:="Invoice Date:", Replacement:=""
'changes to string to desired date format
DateValue = Cells(x, 3).NumberFormat = "dd/mm/yyyy"
Next x
End Sub
Please, someone spare me this misery before either the laptop or me go out the window.
Thanks in advance

Dates are extremely annoying to work with. Your best bet for making sure you're working with the correct date is to use the DateSerial function, and then format the output as desired:
Sub DateConvert()
Dim ws As Worksheet: Set ws = ActiveWorkbook.Worksheets("Sheet1")
Dim rData As Range: Set rData = ws.Range("C2", ws.Cells(ws.Rows.Count, "C").End(xlUp))
If rData.Row < 2 Then Exit Sub 'No data
'Load range data into an array
Dim aData() As Variant
If rData.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = rData.Value
Else
aData = rData.Value
End If
'Loop over array and perform conversion
Dim aDateValues As Variant
Dim i As Long
For i = 1 To UBound(aData, 1)
aDateValues = Split(Replace(aData(i, 1), "Invoice Date:", vbNullString), "/") 'Remove the extra text and pull the date values
aData(i, 1) = DateSerial(aDateValues(2), aDateValues(1), aDateValues(0)) 'Use DateSerial to guarantee correct date
Next i
'Output results to sheet with desired date format
With rData
.Value = aData
.NumberFormat = "dd/mm/yyyy"
End With
End Sub

Related

I have a Product Name like this. I run vba code for extracting date, am not getting the result, it shows error

Code:
Sub My_Date()
Dim endRow As Long
endRow = Cells(rows.Count, "B").End(xlUp).row
ActiveCell.FormulaR1C1 = _
"=DATEVALUE(IF(LEFT(RIGHT(LEFT(RC[1],FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5))-1),FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5))-FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),4))-1),3)=TEXT(TODAY()-1,""Mmm""),RIGHT(LEFT(RC[1],FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5))-1),FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5))-FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHA" & _
"-1),IF(LEFT(RIGHT(LEFT(RC[1],FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),6))-1),FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),6))-FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5))-1),3)=TEXT(TODAY()-1,""Mmm""),RIGHT(LEFT(RC[1],FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),6))-1),FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),6))-FIND(CHAR(1),SUBSTITUTE(RC[1],""_"",CHAR(1),5)" & _
""")))"
range("B2").Autofill Destination:=range("B2:B" & endRow)
End Sub
You could write your own function.
This will split your text by the _ delimiter and return the bit that can be turned into a date.
Sub Test()
Dim endRow As Long
With ThisWorkbook.Worksheets("Sheet1")
endRow = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range(.Cells(2, 1), .Cells(endRow, 1)).FormulaR1C1 = "=ExtractDate(RC2)"
End With
End Sub
Public Function ExtractDate(Target As Range, Optional Delim As String = "_") As Variant
Dim SplitText As Variant
SplitText = Split(Target, Delim)
Dim Itm As Variant
For Each Itm In SplitText
If IsDate(Itm) Then
ExtractDate = CDate(Itm)
Exit For
End If
Next Itm
'If no date found return an #N/A error.
If ExtractDate = 0 Then ExtractDate = CVErr(xlErrNA)
End Function
The cell reference in the Test procedure "=ExtractDate(RC2)" is in the R1C1 format - it means this row (where the formula appears), column 2.
The solution proposed by Darren Bartrup-Cook has a serious pitfall: IsDate and CDate functions work with the month names in a current locale. Which means that in general case they do not recognize May 03 and alike as a date
Let's make it work. Here are the assumptions about our data:
There's a pattern in Product Names with _ as a delimiter: the date always comes sixth in a row.
The year is always meant to be the current one.
The name of the month is always indicated in full.
Function ExtractDate(Text As String)
Const Delimiter = "_"
Const Position = 5 ' starting from zero
ExtractDate = Split(Text, Delimiter)(Position)
End Function
Sub Main_Macro()
Dim Source As Range
Dim DateArea As Range
Set Source = Range(Range("B2"), Range("B2").End(xlDown))
Set DateArea = Source.Offset(0, -1)
With DateArea
.NumberFormat = "[$-409]mmmm d"
.Formula2R1C1 = "=ExtractDate(RC[1])"
.Value2 = .Value2
.NumberFormat = "dd-mm-yyyy"
End With
End Sub
Here:
"[$-409]mmmm d" force to recognize months in English
.Value2 = .Value2 replace the formula with real data
.NumberFormat = "mm-dd-yyyy" set the date format in a current locale

Using DateValue in a Loop

I am trying to change a column of text-based dates in a table into valued dates, so I can later filter them in the next line of code. I wanted the code to go through each row, get the value from the Due Date column, and return the date in the correct format. I get a Run-time error 438 - Object doesn't support this property or method.
'changes the date to correct format
For Each Row In ActiveSheet.ListObjects("ISP_Table")
DueDate = Range("ISP_Table[Due Date]")
Range("ISP_Table[Due Date]") = DateValue(DueDate)
Next Row
'filters out dates more than 3 months in the future
ActiveSheet.ListObjects("ISP_Table").Range.AutoFilter Field:=3, Criteria1:="<" & DateAdd("m", 1, Date)
Loop over the cells in the .DataBodyRange of the ListColumn in question:
Dim cell As Range
For Each cell in ActiveSheet.ListObjects("ISP_Table").ListColumns("Due Date").DataBodyRange
cell.Value = DateValue(cell.Value)
Next
Since looping cell-by-cell is slow, even better, use an array:
Dim rng As Range
Set rng = ActiveSheet.ListObjects("ISP_Table").ListColumns("Due Date").DataBodyRange
Dim arr() As Variant
arr = rng.Value ' read values into array
Dim i As Long
For i = Lbound(arr, 1) to Ubound(arr, 1)
arr(i, 1) = DateValue(arr(i, 1))
Next
rng.Value = arr ' write array back to sheet

VBA - Filtering by Custom Date Format

I'm writing a macro to filter downloaded data according to a certain date range. The problem is that the cells containing dates in the downloaded data use the format mm/dd/yyyy, which Excel recognizes as text. Consequently, any program I write assumes that it is filtering text instead of dates, which causes a number of problems.
Is there a way to make this format recognized as a date by Excel? I tried defining the date cells using a custom number format but it didn't work. Any help would be appreciated.
Please, try the next code. It will convert the column in discussion in Date:
Sub convertTextToDate()
Dim sh As Worksheet, lastR As Long, col As String, arr, arrSp, arrD, i As Long
Set sh = ActiveSheet
col = "A" 'column where the string to be converted in date exists
lastR = sh.cells(sh.rows.count, col).End(xlUp).row
arr = sh.Range(col & "2:" & col & lastR).value
ReDim arrD(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
arrSp = Split(arr(i, 1), "/")
arrD(i, 1) = DateSerial(CLng(arrSp(2)), CLng(arrSp(1)), CLng(arrSp(0)))
Next i
With sh.Range(col & "2:" & col & lastR)
.value = arrD
.NumberFormat = "dd/mm/yyyy"
End With
End Sub
If you need a different format you should change "dd/mm/yyyy" with whatever you want. "mm.dd.yy", for instance...

Increment date column by VBA excel

if i have a column in excel in following format:
"dd/mm/yyyy hh:mm:ss" and i want to increase the hour value by 1.
I add 1/24 to that cell and is done.
my problem is that files where i need this correction have around 15000 rows and operation is taking around 2 minutes.
the code i use is:
Set rngSel = .Range("A2:A10000")
For Each cell In rngSel
cell.Value = cell.Value + dif / 24
Next cell
is it possible somehow to do it faster?
You could try:
Option Explicit
Sub test()
Dim arr As Variant
Dim Initial_DateTime As Date
Dim i As Long
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range("A2:A10000")
For i = LBound(arr) To UBound(arr)
Initial_DateTime = arr(i, 1)
arr(i, 1) = DateAdd("h", 1, Initial_DateTime)
Next i
.Range("A2:A1000").Value = arr
End With
End Sub
As mentioned in the comments, it is much quicker to load the range into a matrix and handle the incrementation of the dates in memory. I have built upon your code for the following example.
Sub IncrementDateColumnByVBA()
Dim rngSel As Range
Dim DateArray() As Variant
Dim i As Long
Dim dif As Byte
dif = 1
Set rngSel = ActiveSheet.Range("A2:A10")
'Write range to a matrix
DateArray = rngSel.Value
'Loop matrix
For i = LBound(DateArray) To UBound(DateArray)
DateArray(i, 1) = DateArray(i, 1) + dif / 24
Next i
'Write matrix to worksheet
rngSel.Value = DateArray
End Sub

Finding Max Date from "Find" Range

I have a variety of calibration tests. I keep all different types and their dates in one worksheet "wsCAL"
I want to populate the userform with the most recent date of one specific type of test, which is stored in Column C in wsCAL.
In theory, I want VBA to go to wsCAL, look thru column C and find all instances of one test type, find the most recent date(or MAX) in column B of those instances, then populate my userform with that date.
I've tried using the rangeCAL = .Find() function to find all instances of a test type in column C. This part works just fine. However, the application.worksheetfunction.Max(rangeCAL) I try to use fails. I'm guessing it is because that application function only works with worksheet ranges and not Find() ones. I'm struggling with taking my rangeCAL cells, making an array, then finding the most recent date (the MAX) of those.
Private Sub UserForm_Initialize() 'Upon opening the userform
Set wb = ThisWorkbook
Set wsHOME = wb.Worksheets("Home")
Set wsCAL = wb.Worksheets("Bottle Calibrations")
Set wsC1T1 = wb.Worksheets("C1T1")
'Last Calibration Date
Label27.Caption = vbNullString
With wsCAL
Dim Cell As Range
Dim myArray As Date
Dim i As Integer
Dim rangeCAL As Range
Dim rangeDateCAL As Date
i = 0
Set rangeCAL = Range("C:C").Find(What:=tank, LookAt:=xlWhole)
If Not rangeCAL Is Nothing Then
For Each Cell In rangeCAL
myArray(i) = .Range(rangeCAL.Row, "A").Value
i = i + 1
Next
Else
MsgBox "Error: no previous Calibration dates loaded."
End If
rangeDateCAL = Application.WorksheetFunction.Max(myArray)
rangeDateCAL = Format(rangeDateCAL, "yymmdd")
End With
Label27.Caption = rangeDateCAL
I keep getting the error message
"Expected array"
as soon as I get to line:
myArray(i) = .Range(rangeCAL.Row, "B").Value
UPDATE:
Label27.Caption = vbNullString
With wsCAL
Dim Cell As Range
Dim myArray(1 To 5) As Date
Dim i As Long
Dim temp As Date
Dim rangeCAL As Range
Dim rangeDateCAL As Date
i = 1
Set rangeCAL = wsCAL.Range("C1", Range("C1").End(xlDown).Address)
For Each Cell In rangeCAL
If Cell <> "" Then
If Cell.Value = tank Then
temp = wsCAL.Cells(Cell.Row, "B").Value
myArray(i) = temp
i = i + 1
End If
End If
Next
rangeDateCAL = Application.WorksheetFunction.Max(myArray)
rangeDateCAL = Format(rangeDateCAL, "yymmdd")
End With
Label27.Caption = rangeDateCAL
I implemented this change after reading your comments. This code runs, but it fills Label27.Caption with 11/22/4613 instead of the intended 11/7/2019.
I'm assuming the date value is being altered at the MAX function step, but I'm not sure what else I can change.
For Each Cell In rangeCAL
If Cell.Text <> vbNullString Then
If Cell.Text = tank Then 'assuming tank is declared a string
If tempDate < wsCAL.Cells(Cell.Row, "B").Value Then
tempDate = wsCAL.Cells(Cell.Row, "B").Value
End If
End If
End If
Next
Label27.Caption = Format(tempDate, "yymmdd")
This is what I implemented, per SmileyFTW's suggestion. Far simpler than anticipated. Works as intended though. Thank you SmileyFTW, and the others who commented with help.
Label27.Caption = vbNullString
With wsCAL
Dim Cell As Range
Dim i As Date
Dim temp As Date
Dim rangeCAL As Range
temp = 0
Set rangeCAL = wsCAL.Range("C1", Range("C1").End(xlDown).Address)
For Each Cell In rangeCAL
If Cell <> vbNullString Then
If Cell.Value = tank Then
i = wsCAL.Cells(Cell.Row, "B").Text
If i > temp Then
temp = i
End If
End If
End If
Next
End With
Label27.Caption = temp

Resources