I import a date into an Excel sheet from a text file. The date has the form: YYYY.MM.DD.
I want to reverse the date so as to be: DD/MM/YYYY.
I have tried NumberFormat, Format and some other subroutines.
Here is the code:
Sub ImportRange()
Dim Filename As String
Dim Data
Dim Pos As Integer
On Error Resume Next
Filename = Application.DefaultFilePath & "\putty.log"
Open Filename For Input As #1
If Err <> 0 Then
MsgBox "Not found:" & Filename, vbCritical, "ERROR"
Exit Sub
End If
Application.ScreenUpdating = False
Line Input #1, Data
Close #1
Pos = InStr(Data, "log")
Sheets("ÐÉÓÔÏÐÏÉÇÔÉÊÏ").Range("B20").Value = Mid(Data, Pos + 4, 10)
Application.ScreenUpdating = True
End Sub
I have inserted a sample formula for the conversion let me know if this helps.
If cell A2 has the given date you can insert the given formula in B2
=DATE(VALUE(LEFT(A2,4)),VALUE(MID(A2,6,2)),VALUE(RIGHT(A2,2)))
Be sure that the actual cells that the dates are going in to formatted as a date
Related
I would like to use the date from inputbox , then compare it with the date in the excel sheet , so my code as below :
Sub test()
Dim date1 As Date
Date = InputBox("input the date ")
If date1 = Sheet3.Range("A2").Value Then
Debug.Print "TRUE"
Else
Debug.Print "FALSE"
End If
End Sub
the result it got is always "FALSE" in the immediate box although i have set the date match with the date inputted from inputbox , can you please assist on this case ? Any assist is appreciated.
The InputBox always returns a string, so convert this:
Sub test()
Dim Date1 As Date
Dim Value As String
Value = InputBox("Input the date")
If IsDate(Value) Then
Date1 = DateValue(Value)
If DateDiff("d", Date1, Sheet3.Range("A2").Value) = 0 Then
Debug.Print "TRUE"
Else
Debug.Print "FALSE"
End If
Else
Debug.Print "N/A"
End If
End Sub
A short solution, protected against the error of mismatching the type of input data and the data on the sheet (text or error instead of date in a cell)
Debug.Print IIf(InputBox("Input the date: ") = Sheet3.Range("A2").Text, "TRUE", "FALSE")
I have a report that is imported into excel every day, and the last column of information "Z", is all of the comments that have been left by previous agents working on the account. I am only interested in the last comment, but it can be of any length, so i cant just grab x amount of characters.
Question: Is there a way to only pull the last comment based on the criteria of the comment? (every comment ends with the username, date, and time-stamp:
Example of a cell:
Example of agent1 comment. [USERNAME1-xx/xx/xxxx xx:xx:xx PM] - Example of agent2 comment. [USERNAME2-xx/xx/xxxx xx:xx:xx PM])
In this scenario, the only text that i would want in the cell would be: "Example of agent2 comment.".
For the record, all of the imported report starts on "A2".
Guess I shouldn't do this as you haven't shown what you've tried yet, but this code should do the trick.
Enter in a cell: =ExtractLastComment(H3) where H3 contains the comment.
'Use this procedure to run on a range of cells.
'The result is placed one cell to the right of the comment: "Offset(, 1)"
Public Sub CommentsInColumn()
Dim rTarget As Range
Dim rCell As Range
Set rTarget = ThisWorkbook.Worksheets("Sheet1").Range("A2:A30")
For Each rCell In rTarget
rCell.Offset(, 1) = ExtractLastComment(rCell)
Next rCell
End Sub
Public Function ExtractLastComment(Target As Range) As Variant
Dim sCommentText As String
If HasComment(Target) Then
'Get the comment text.
sCommentText = Target.Comment.Text
If InStrRev(sCommentText, "[") <> 0 Then
'Find the last open bracket and take everything to the left of it.
sCommentText = Trim(Left(sCommentText, InStrRev(sCommentText, "[") - 1))
'Any closing brackets left?
If InStrRev(sCommentText, "]") <> 0 Then
'Take everything from last closing bracket to end of text.
sCommentText = Mid(sCommentText, InStrRev(sCommentText, "]") + 4)
End If
ExtractLastComment = sCommentText
Else
ExtractLastComment = CVErr(xlErrValue)
End If
Else
'There isn't a comment in the cell, return a !#NULL error.
ExtractLastComment = CVErr(xlErrNull)
End If
End Function
Public Function HasComment(Target As Range) As Boolean
On Error GoTo ERROR_HANDLER
If Target.Cells.Count = 1 Then
With Target
HasComment = Not .Comment Is Nothing
End With
Else
Err.Raise 513, "HasComment()", "Argument must reference single cell."
End If
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure HasComment."
Err.Clear
Application.EnableEvents = True
End Select
End Function
I have an excel sheet than when its first opened it asks the user to enter a date into the input box and it places it into a cell in the sheet. I have an error handle to pop up an invalid date error box if someone puts in the wrong date. But what I want to do is when an invalid date is entered the original input box for the date pops up again so they can reenter again. I have the code below of what I have written so far but I keep getting an error.
Thanks
ReShowInputBox: cellvalue = Application.InputBox("Please Enter The Date for Data Extracted (dd/mm/yyyy)")
On Error GoTo ErrHandle
ErrHandle:
MsgBox ("Invalid Date")
ReShowInputBox: cellvalue = Application.InputBox("Please Enter The Date for Data Extracted (dd/mm/yyyy)")
If cellvalue = "" Then Exit Sub
ws.Select
ws.Range("A1").Value = DateValue(cellvalue)
MsgBox ("Date Entered!")
How about a simple Do Until Loop:
Dim cellvalue As Variant
Do
cellvalue = Application.InputBox("Please Enter The Date for Data Extracted (dd/mm/yyyy)")
Loop Until IsDate(cellvalue) And IsNumeric(Right(cellvalue, 4)) And IsNumeric(Left(cellvalue, 2)) And IsNumeric(Mid(cellvalue, 4,2))
ws.Range("A1").Value = cellvalue
MsgBox ("Date Entered!")
I tested this pretty thoroughly and it only accepted dates in the exact format you desire.
Here is a simple way to repeatedly ask for a date until you get one, but allow the user to cancel out:
Sub fhskjfs()
Dim i As String, d As Date
i = ""
While Not IsDate(i)
i = Application.InputBox(Prompt:="Enter a date", Type:=2)
If i = False Then Exit Sub
If IsDate(i) Then d = CDate(i)
Wend
End Sub
EDIT#1:
Here is a way to implement a simple format check:
Public Function CheckFormat(i As String) As String
CheckFormat = "junk"
ary = Split(i, "/")
If UBound(ary) <> 2 Then Exit Function
If CLng(ary(2)) < 1900 Or CLng(ary(2)) > 9999 Then Exit Function
If CLng(ary(1)) > 12 Then Exit Function
If CLng(ary(0)) > 31 Then Exit Function
CheckFormat = i
End Function
Sub GetDate()
Dim i As String, d As Date
i = ""
While Not IsDate(i)
i = Application.InputBox(Prompt:="Enter a date", Type:=2)
If i = "False" Then Exit Sub
i = CheckFormat(i)
If IsDate(i) Then d = CDate(i)
Wend
End Sub
Here is my code of two sub procedures, one function, two other sub procedures for macro protection (irrelevant). The last sub procedure, sub manual_date() is the center of my inquiry. How could I divert the macro code if the user of this macro choose to manually input their own date. The main code is highlighted as the center code screen. I know I could very easily copy and paste as a solution. I am interested in an advanced coding strategy.
Option Explicit
Sub Client_Dirty_Recon()
Dim Date_minus_one As Date ' Date & weekend logic
Dim answer As Long ' Date & weekend logic
Dim brow As Long ' Last filled cell in column
Dim yrow As Long ' Last filled cell in column
Dim nRow As Long ' Last filled cell in column
Dim c As Range ' rngWatch.Cells(i, 1).Value
Dim oldStatusBar As Variant ' Save StatusBar status
Dim Client_path As String ' Range("Path")
Dim wb As Workbook ' ThisWorkbook
Dim wbDirty As Workbook ' Workbooks.Open(Client_path)
Dim rngReconcile As Range ' wb.Sheets(1).Range("K:K")
Dim rngWatch As Range ' wbDirty.Sheets(1).Range("A:A")
Dim rngNew As Range ' wbNew.Sheets(1).Range("A:A")
Dim failed_count As Long
Dim FS
oldStatusBar = Application.DisplayStatusBar 'optional - save StatusBar
Application.DisplayStatusBar = True 'optional - turn on StatusBar
Application.ScreenUpdating = False 'optional - screen won't flash
Application.StatusBar = "Opening workbooks..." 'optional - Update user
Call Unprot
Date_minus_one = Date
answer = IsMonday(Date_minus_one)
If answer = True Then
Date_minus_one = Date - 3
Else
Date_minus_one = Date - 1
End If
Set FS = CreateObject("Scripting.FileSystemObject")
Set wb = ThisWorkbook
' Client_path = wb.Names("Path").RefersToRange.Value ' use path as defined name on sheet
Client_path = "XXXXXXX " & Format(Date_minus_one, "mmddyyyy") & ".xls"
If FS.fileexists(Client_path) Then
' Get only used part of column
Set rngReconcile = wb.Sheets(1).Range("K:K")
nRow = rngReconcile(rngReconcile.Cells.Count).End(xlUp).Row ' Get last filled cell
Set rngReconcile = Range(rngReconcile(1), rngReconcile(nRow)) ' Reduce rng size
Set wbDirty = Workbooks.Open(Client_path) ' Assumes it exists and is not open
' Get only used part of column
Set rngWatch = wbDirty.Sheets(1).Range("A:A")
nRow = rngWatch(rngWatch.Cells.Count).End(xlUp).Row ' Get last filled cell
Set rngWatch = Range(rngWatch(3), rngWatch(nRow)) ' Reduce range size
Set rngNew = wb.Sheets("Client Watchlist").Range("K:K")
brow = rngNew(rngNew.Cells.Count).End(xlUp).Row
Set rngNew = Range(rngNew(2), rngNew(brow))
rngNew.ClearContents
Set rngNew = wb.Sheets(1).Range("K:K")(rngNew.Cells.Count).End(xlUp)(2)
For Each c In rngWatch ' Each value in rngWatch
On Error Resume Next ' Interrupt Error checking
If IsError(WorksheetFunction.Match( _
c.Value, rngReconcile, 0)) Then ' If not in rngReconcile
rngNew.FormulaR1C1 = c.Value ' Copy to rngNew
Set rngNew = rngNew(2) ' Moves range down =Offset(rngNew,1,0)
End If
On Error GoTo 0 ' Reset Error checking
If (c.Row + 1) Mod 100 = 0 Then ' Optional - Update user
Application.StatusBar = "Evaluating cell " & c(2).Address & "..."
End If
Next c
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar ' Reset Status Bar
ActiveWindow.Close Savechanges:=False ' Closes client email
MsgBox ("Reconcilied to ") & Client_path & " on " & Now
Else
MsgBox ("Please save down ") & Client_path, vbCritical
End If
Call Prot
Application.ScreenUpdating = True ' Turn back on
End Sub
Public Function IsMonday(inputdate As Date) As Boolean
Select Case Weekday(inputdate)
Case vbMonday
IsMonday = True
Case Else
IsMonday = False
End Select
End Function
Sub manual_date()
manual_date_input = InputBox("Enter Date (MMDDYYYY")
End Sub
Update
I added the following two sub procedures which shall pass the dt parameter as instructed below. I feel as if this variable dt as date is storing a value? I am able to run the sub procedure Sub RunWithUserDate() but the Sub RunWithDefault() procedure does not run smoothly. I have inserted several message boxes to view the value of dt. Should I be resetting the value of this date variable? If so, how could I? (Please note, I have cleaned up the code within the main sub procedure Sub Client_Dirty_Recon() and I have properly assigned the dt variable within the client_path variable.
Sub test2()
MsgBox Date
MsgBox dt
MsgBox IsMonday(dt)
IsMonday (dt)
MsgBox (dt)
End Sub
Public Function IsMonday(inputdate As Date) As Boolean
Select Case Weekday(inputdate)
Case vbMonday
dt = Date - 3 ' IsMonday = True
'dt = Format(dt, "mmddyyyy")
Case Else
dt = Date - 1
'dt = Format(Date - 1, "mmddyyyy") ' IsMonday = False
'dt = Format(dt, "mmddyyyy")
End Select
End Function
Sub RunWithDefault() ' Button 1: use current date
'CHECK THIS AGAIN ***ALSO ADD PERMISSIONS IF NECESSARY
MsgBox IsMonday(dt)
MsgBox dt
Client_Dirty_Recon IsMonday(dt)
End Sub
' Button 2: get date from user
Sub RunWithUserDate() ' Get dt value from user
'PROMPT USER FOR PASSWORD
dt = Application.InputBox("Enter Date (MM/DD/YYYY)", "Manual Override")
'du = Format(du, "mmddyyyy")
'du = Format(Application.InputBox("Enter Date (MM/DD/YYYY)"), "mmddyyyy")
'dt = Format(dt, "mmddyyyy")
'MsgBox dt
Client_Dirty_Recon dt
'dt = Date
End Sub
Add a Date parameter to your main sub, and have (e.g.) two separate buttons, each linked to smaller "stubs" which in turn will call the main code. First one would pass the current date; second one would pass a date sourced from the user somehow.
'button 1: use current date
Sub RunWithDefault()
Client_Dirty_Recon Date
End Sub
'button 2: get date from user
Sub RunWithUserDate()
Dim dt As Date
'get dt value from user
Client_Dirty_Recon dt
End Sub
'main code
Sub Client_Dirty_Recon(dt as Date)
'run main processing
End Sub
I am currently attempting to self-teach myself the great world of macro coding in VBA but have come across a stumbling block when trying to process 3 macros that I would ideally like to process as 1 but the code seems to be far too complicated for me at this stage.
What I need is to convert data from US date format mm/dd/yyyy into UK date format dd.mm.yyyy and changing the / to . at the same time ideally overwriting the original data.
This is currently what I have in separate Modules:
Sub FixFormat()
'display a message with an option if US date formats are
'included in the data
MsgBox "US Date Formats Included", vbQuestion + vbYesNo, "Addresses"
If Response = Yes Then MsgBox "Delimit Process Needed", vbOKOnly, "Addresses"
If Response = No Then MsgBox "End", vbOKOnly
End
End Sub
and
Sub FixDates()
Dim cell As Range
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & lastRow)
If InStr(cell.Value, ".") <> 0 Then
cell.Value = RegexReplace(cell.Value, _
"(\d{2})\.(\d{2})\.(\d{4})", "$3.$2.$1")
End If
If InStr(cell.Value, "/") <> 0 Then
cell.Value = RegexReplace(cell.Value, _
"(\d{2})/(\d{2})/(\d{4})", "$3.$1.$2")
End If
cell.NumberFormat = "yyyy-mm-d;#"
Next
End Sub
Function RegexReplace(ByVal text As String, _
ByVal replace_what As String, _
ByVal replace_with As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = replace_what
RE.Global = True
RegexReplace = RE.Replace(text, replace_with)
End Function
Is there any way to do this without having to run 2 separate macros?
Yes, you can Call the subroutine you want to run as a result of the message box.
Sub FixFormat()
'display a message with an option if US date formats are
'included in the data
If MsgBox("US Date Formats Included", vbQuestion + vbYesNo, "Addresses") = 6 Then
MsgBox "Delimit Process Needed", vbOKOnly, "Addresses"
Call FixDates
Else
MsgBox "End", vbOKOnly
End If
End Sub
See this link for more information on the MsgBox function: http://msdn.microsoft.com/en-us/library/139z2azd(v=vs.90).aspx