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
Related
I'm trying to duplicate selected slides multiple times in the same presentation. Could someone please advise where I am going wrong? Thank you
Public Sub DuplicateSlideMultipleTimes()
Dim n As Integer
On Error Resume Next
n = InputBox("How many copies of the selected slides do you want to make?")
Dim mySlides As Slides
Set mySlides = ActiveWindow.Selection.SlideRange
If n >= 1 Then
For numtimes = 1 To n
mySlides.Copy After:=ActivePresentation.Slides(ActivePresentation.Slides.Count)
Next
End If
End Sub
Here's another approach. Instead of looping through each of the selected slides to make a duplicate, it simply copies and pastes. It also places them at the end of the presentation.
Note that mySlides has been appropriately declared as a SlideRange, as Ricardo has already pointed out.
Also note that On Error Resume Next has been removed, since it can hide errors when not used properly, as Ricardo has also pointed out.
Option Explicit
Public Sub DuplicateSlideMultipleTimes()
Dim ans As String
Dim num_copies As Long
num_copies = 0
Do
ans = InputBox("How many copies of the selected slides do you want to make?")
If Len(ans) = 0 Then Exit Sub
If IsNumeric(ans) Then
num_copies = CLng(ans)
If num_copies > 1 Then Exit Do
End If
MsgBox "Invalid entry, try again!", vbExclamation
Loop
Dim mySlides As SlideRange
Set mySlides = ActiveWindow.Selection.SlideRange
Dim i As Long
For i = 1 To num_copies
mySlides.Copy
ActivePresentation.Slides.Paste
Next i
MsgBox "Completed!", vbExclamation
End Sub
You were close.
Some highlights:
Avoid On Error Resume Next whenever possible (this will just hide where you have errors)
Declare all your variables (use Option Explicit at the top of your modules)
You have some variables types wrong
Review code's comments and adjust it to fit your needs
Code:
Option Explicit
Public Sub DuplicateSlideMultipleTimes()
Dim sourceSlide As Slide
Dim selectedSlides As SlideRange
Dim numTimes As Variant
Dim counter As Long
Dim totalCounter As Long
' Ask user for num slides
numTimes = InputBox("How many copies of the selected slides do you want to make?")
' Check if numTimes is a number otherwise, exit procedure
If Not IsNumeric(numTimes) Then Exit Sub
' Set a reference to the selected slides
Set selectedSlides = ActiveWindow.Selection.SlideRange
' Loop through each slide in the selected slides
For Each sourceSlide In selectedSlides
For counter = 1 To numTimes
' Duplicate the slide
sourceSlide.Duplicate
' Track total number of duplicated slides
totalCounter = totalCounter + 1
Next counter
Next sourceSlide
' Display message to user
MsgBox totalCounter & " duplicates generated"
End Sub
Let me know if it works
I have VBA that counts time spent on the project and after user is pressing STOP button it enters time into other sheet. Everything is working fine expect for SUM formula to calculate total amount of hours spent. Formula =SUM(A2:A15290) gives value of 00:00:00 (zero) in cell A1. I have tried to "Format cell" in different ways but nothing works. If I enter time manually to cells, then everything works fine. Maybe problem is in my VBA that is entering counted time to cells?
Here is the macro I am using:
Option Explicit
Sub StartTimer()
Dim Start As Single, RunTime As Single
Dim ElapsedTime As String
'Set the control cell to 0 and make it green
Range("Y18").Value = 0
Range("Y14").Interior.Color = 5296274 'Green
Start = Timer ' Set start time.
Debug.Print Start
Do While Range("Y18").Value = 0
DoEvents ' Yield to other processes.
RunTime = Timer ' current elapsed time
ElapsedTime = Format((RunTime - Start) / 86400, "h:mm:ss")
'Display currently elapsed time in A1
Range("Y14").Value = ElapsedTime
Application.StatusBar = ElapsedTime
Loop
Range("Y14").Value = ElapsedTime
Range("Y14").Interior.Color = 192 'Dark red
Application.StatusBar = False
End Sub
Sub StopTimer()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
'Set the control cell to 1
Range("Y18").Value = 1
Set copySheet = Worksheets("MAIN")
Set pasteSheet = Worksheets("Time Spent")
copySheet.Range("Y14").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
You are putting text-that-looks-like-time into the cells. Use real time.
Dim Start As DOUBLE, RunTime As DOUBLE
Dim ElapsedTime As DOUBLE
...
Start = Timer ' Set start time.
...
DoEvents ' Yield to other processes.
RunTime = Timer ' current elapsed time
ElapsedTime = (RunTime - Start) / 86400
Range("Y14").Value = ElapsedTime
Range("Y14").numberformat = "[hh]:mm:ss"
Remember to be careful about a start and end that cross midnight. Timer resets at midnight and Excel doesn't like negative time.
I have created a macro in Powerpoint that will search for slides that are using a textbox for their title and are replacing them with a Title box. The steps are
1) find the slides that have a textbox in the title area
2) Copy the text in the textbox to a variable called slTitle.
3) Delete the texbox
4) Create a Title Holder for the current slide
5) Copy the text into the Title holder
6) Move on to the next slide
My macro currently is able to get as far as step 4 but I can't figure out how to get the text in slTitle into the Title box. This should be fairly easy to do but I've tried several ways and nothing seems to work. If anyone can help me figure out this step it would be much appreciated.
I am getting a compile error "Invalid Qualifier" on the line:
Set ppPlaceholderTitle.TextFrame.TextRange.Text = slTitle
Here is my current macro.
Sub AddMiMissingTitles()
Dim shpCurrShape As Object
Dim x As Integer
Dim sl As PowerPoint.Slide
Dim sld As Slide
Dim ctr As Integer
Dim s As Shape
'x = ActivePresentation.Slides.Count
'counter ctr used to count number of slides that needed titles added
ctr = 0
'**************************************************************
Set sourcePres = ActivePresentation
x = 1 ' slide counter
'get the title text
For Each sl In sourcePres.Slides
'delete all the empty title text boxes first
For Each s In sl.Shapes
If s.Top < 45 Then ' it's in the title area
'MsgBox s.PlaceholderFormat.Type
If s.Type <> ppPlaceholderTitle Then ' it isn't a proper Title placeholder
If s.HasTextFrame = msoTrue Then
If Trim(s.TextFrame.TextRange.Text) = "" Then
s.Delete ' delete empty text holders
Else
slTitle = s.TextFrame.TextRange.Text
s.Delete
sl.CustomLayout = sl.CustomLayout 'reset the slide
Set ppPlaceholderTitle.TextFrame.TextRange.Text = slTitle
End If
End If
End If
End If
Next
'Is there a title placeholder on the current layout?
If sl.CustomLayout.Shapes.HasTitle Then
lngType = sl.CustomLayout.Shapes.Title.PlaceholderFormat.Type
'*********************************
' With ActivePresentation.Slides()
End If
Next
MsgBox "Done! " & vbCrLf & ctr & " Slides needed Titles."
'*********************************
'sl.Shapes.AddPlaceholder lngType
sl.Shapes.Title.TextFrame.TextRange = slTitle
End Sub
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.
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