I have a spreadsheet with data input by multiple users.
I would like to set up an autoexecute macro for all values in the spread sheet to be set to zero on the 15th and 30th of every month when users open the spreadsheet.
Please help.
This should do what you're after.
Private Sub Workbook_Open()
Dim dt As String
'GET THE CURRENT DAY OF MONTH
dt = Format(Now(), "DD")
'IF THE DATE IS 15th or 30th
If dt = "15" Or dt = "30" Then
'IF THE "DONE" VALUE IS BLANK
If Sheets(1).Range("XFD1").Value = "" Then
'CLEAR ALL CELLS IN SHEET 1
Sheets(1).Cells.Clear
'SET VALUE TO "DONE" SO THE MACRO KNOWS THE DATA WIPE HAS ALREADY BEEN PERFORMED
Sheets(1).Range("XFD1").Value = "DONE"
End If
End If
'IF THE DATE IS NOT 15TH OR 30TH, CLEAR THE "DONE" VALUE SO THE MACRO CAN RUN AGAIN THE NEXT TIME
If dt <> "15" And dt <> "30" Then
Sheets(1).Range("XFD1").Value = ""
End If
End Sub
Let me know if anything is unclear.
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")
Actually I am writing a code for highlight or delete the rows where column "A" has > the date selected in combo box. I am using below codes
Private Sub ComboBox1_Change()
Application.EnableEvents = False
ComboBox1.Value = Format(ComboBox1.Value, "dd-mm-yyyy")
Application.EnableEvents = True
End Sub
Private Sub ComboBox2_Change()
ComboBox2.Value = Format(ComboBox2.Value, "dd-mm-yyyy")
End Sub
Private Sub okButton_Click()
Dim i As Long
For i = 2 To 6724
If Range("A" & i).Value > ComboBox1.Value Then
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
End If
Next
End Sub
When I execute this nothing happens.
Then print combo box value in cell so that I can find out the place where the problem is, and I found that the date format in combo box & print date is different in format.
there may be other issue with my code & enable event= false is also not working. any help will be greatly appreciated.
I'm on an iPad now and can't check what I propose, but the way I would tackle this problem is to ensure that column A has a date in it, a value like 41234, and never mind how that cell is formatted.
You can convert any date in Combobox1 using CDate(Combobox1.Value). Bear in mind that CDate requires a valid date in string format. The result of the CDate function is a Long, which is comparable with the date value in your column A. You should be able to use your existing code to act on it.
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
I am creating a VBA program in powerpoint to countdown the days until shipping date. (To run on screens in a plant) I am familiar with VBA for Excel but not with powerpoint. I have the start of the code but I need help with looping it continously and having a timer for each slide.Thanks!
EDIT
This is what I have so far!
Private Sub CommandButton1_Click()
'Sets variables
Dim Sdate As Long
Dim thedate As Date
Dim txt As Date
Dim pptSlide3 As PowerPoint.Slide
Set sld = ActivePresentation.SlideShowWindow.View.Slide
For Each pptSlide3 In ActivePresentation
'Retrieves D-Day from text box shown above
TextBox2.Font.Size = 12
thedate = TextBox2.Text
'Calculates the amount of time from today's date until D-day above
Sdate = DateDiff("d", Now(), thedate)
'Creates textbox with the value of how many days are left
TextBox1.Value = Sdate & " Days to go!"
TextBox1.Font.Size = 36
'Want it to wait 5 seconds here
' Goes to next slide
With SlideShowWindows(1).View
.GotoSlide (sld.SlideIndex + 1)
End With
'I also want the slideshow to loop continuously, do this for every slide and then loop through them again until the user exits powerpoint
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