SOLVED

Macro button

%3CLINGO-SUB%20id%3D%22lingo-sub-2251706%22%20slang%3D%22en-US%22%3EMacro%20button%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2251706%22%20slang%3D%22en-US%22%3E%3CP%3EHi%20all.%20I'm%20new%20here.%3CBR%20%2F%3EI%20would%20like%20to%20create%20a%20button%20macro%20that%20when%20I%20click%20it%2C%20it%20will%20go%20to%20a%20cell%20according%20to%20the%20time%20(each%20cell%20represents%20a%2015%20min%20time)%20and%20increase%20the%20number%20in%20that%20cell%20by%20one.%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-2251706%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EExcel%3C%2FLINGO-LABEL%3E%3CLINGO-LABEL%3EFormulas%20and%20Functions%3C%2FLINGO-LABEL%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3CLINGO-LABEL%3EOffice%20365%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2251974%22%20slang%3D%22en-US%22%3ERe%3A%20Macro%20button%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2251974%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F94152%22%20target%3D%22_blank%22%3E%40Phil%20Cox%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%0A%3CP%3EPlease%20attach%20a%20sample%20workbook%20without%20sensitive%20data.%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2252566%22%20slang%3D%22en-US%22%3ERe%3A%20Macro%20button%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2252566%22%20slang%3D%22en-US%22%3EThanks%20Hans.%20I%20uploaded%20my%20spreadsheet.%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2252745%22%20slang%3D%22en-US%22%3ERe%3A%20Macro%20button%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2252745%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F94152%22%20target%3D%22_blank%22%3E%40Phil%20Cox%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EPlease%20find%20the%20attached%20with%20the%20code%20on%20Module1.%20I%20replaced%20the%20ActiveX%20Commandbuttons%20you%20inserted%20on%20Input%20Sheet%20with%20the%20Rectangular%20Shapes%20and%20renamed%20them%20properly%20to%20make%20it%20work%20correctly.%20Please%20don't%20mess%20with%20the%20names%20and%20captions%20of%20these%20buttons.%20The%20code%20on%20Module1%20is%20assigned%20to%20all%20of%20these%20buttons.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%3CU%3E%3CSTRONG%3ECode%20on%20Module1%3A%3C%2FSTRONG%3E%3C%2FU%3E%3C%2FP%3E%3CPRE%20class%3D%22lia-code-sample%20language-visual%22%3E%3CCODE%3ESub%20FillData()%0ADim%20wsInput%20%20%20%20%20As%20Worksheet%0ADim%20wsData%20%20%20%20%20%20As%20Worksheet%0ADim%20shp%20%20%20%20%20%20%20%20%20As%20Shape%0ADim%20TimeCol%20%20%20%20%20As%20Variant%0ADim%20x%20%20%20%20%20%20%20%20%20%20%20As%20Long%0ADim%20r%20%20%20%20%20%20%20%20%20%20%20As%20Variant%0ADim%20EType%20%20%20%20%20%20%20As%20String%0ADim%20Region%20%20%20%20%20%20As%20String%0A%0AIf%20Time%20%26gt%3B%20TimeSerial(18%2C%2030%2C%200)%20And%20Time%20%26lt%3B%20TimeSerial(5%2C%2030%2C%200)%20Then%0A%20%20%20%20MsgBox%20%22Out%20of%20scheduled%20time!%22%2C%20vbExclamation%0A%20%20%20%20Exit%20Sub%0AEnd%20If%0ASet%20wsInput%20%3D%20ThisWorkbook.Worksheets(%22Input%20Sheet%22)%0ASet%20wsData%20%3D%20ThisWorkbook.Worksheets(%22Data%20Sheet%22)%0A%0ASet%20shp%20%3D%20wsInput.Shapes(Application.Caller)%0A%0AEType%20%3D%20shp.OLEFormat.Object.Caption%0ARegion%20%3D%20Split(shp.Name%2C%20%22_%22)(1)%0A%0AIf%20EType%20%3D%20%22Emp%22%20Then%0A%20%20%20%20x%20%3D%200%0AElseIf%20EType%20%3D%20%22Vet%22%20Then%0A%20%20%20%20x%20%3D%201%0AEnd%20If%0A%0AOn%20Error%20Resume%20Next%0ATimeCol%20%3D%20Application.Match(CDbl(Time)%2C%20wsData.Rows(3))%0Ar%20%3D%20Application.Match(Region%2C%20wsData.Columns(1)%2C%200)%0AOn%20Error%20GoTo%200%0A%0AIf%20IsError(TimeCol)%20Then%0A%20%20%20%20MsgBox%20%22No%20time%20slot%20was%20found%20on%20Data%20Sheet!%22%2C%20vbExclamation%0A%20%20%20%20Exit%20Sub%0AEnd%20If%0A%0AIf%20IsError(r)%20Then%0A%20%20%20%20MsgBox%20%22No%20header%20for%20%22%22%22%20%26amp%3B%20Region%20%26amp%3B%20%22%22%22%20was%20found%20in%20column%20A%20of%20%22%20%26amp%3B%20wsData.Name%20%26amp%3B%20%22!%22%2C%20vbExclamation%0A%20%20%20%20Exit%20Sub%0AEnd%20If%0A%0AWith%20wsData.Cells(r%2C%20TimeCol%20%2B%20x)%0A%20%20%20%20.Value%20%3D%201%0A%20%20%20%20.Interior.Color%20%3D%20vbYellow%0AEnd%20With%0AApplication.Goto%20wsData.Cells(r%2C%20TimeCol%20%2B%20x)%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-2253108%22%20slang%3D%22en-US%22%3ERe%3A%20Macro%20button%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-2253108%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F394231%22%20target%3D%22_blank%22%3E%40Subodh_Tiwari_sktneer%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EThat%20works%20perfect.%20Thank%20you%20so%20much!!!!!!%3C%2FP%3E%3C%2FLINGO-BODY%3E
New Contributor

Hi all. I'm new here.
I would like to create a button macro that when I click it, it will go to a cell according to the time (each cell represents a 15 min time) and increase the number in that cell by one.

8 Replies

@Phil Cox 

Please attach a sample workbook without sensitive data.

Thanks Hans. I uploaded my spreadsheet.

@Phil Cox 

 

Please find the attached with the code on Module1. I replaced the ActiveX Commandbuttons you inserted on Input Sheet with the Rectangular Shapes and renamed them properly to make it work correctly. Please don't mess with the names and captions of these buttons. The code on Module1 is assigned to all of these buttons.

 

Code on Module1:

Sub FillData()
Dim wsInput     As Worksheet
Dim wsData      As Worksheet
Dim shp         As Shape
Dim TimeCol     As Variant
Dim x           As Long
Dim r           As Variant
Dim EType       As String
Dim Region      As String

If Time > TimeSerial(18, 30, 0) And Time < TimeSerial(5, 30, 0) Then
    MsgBox "Out of scheduled time!", vbExclamation
    Exit Sub
End If
Set wsInput = ThisWorkbook.Worksheets("Input Sheet")
Set wsData = ThisWorkbook.Worksheets("Data Sheet")

Set shp = wsInput.Shapes(Application.Caller)

EType = shp.OLEFormat.Object.Caption
Region = Split(shp.Name, "_")(1)

If EType = "Emp" Then
    x = 0
ElseIf EType = "Vet" Then
    x = 1
End If

On Error Resume Next
TimeCol = Application.Match(CDbl(Time), wsData.Rows(3))
r = Application.Match(Region, wsData.Columns(1), 0)
On Error GoTo 0

If IsError(TimeCol) Then
    MsgBox "No time slot was found on Data Sheet!", vbExclamation
    Exit Sub
End If

If IsError(r) Then
    MsgBox "No header for """ & Region & """ was found in column A of " & wsData.Name & "!", vbExclamation
    Exit Sub
End If

With wsData.Cells(r, TimeCol + x)
    .Value = 1
    .Interior.Color = vbYellow
End With
Application.Goto wsData.Cells(r, TimeCol + x)
End Sub

 

 

 

@Subodh_Tiwari_sktneer 

 

That works perfect. Thank you so much!!!!!!

@Phil Cox 

One more thing. The count on the data sheet only goes to one. I would like to increase what ever number is there by 1 each time I click the bottom. So if I click it four times in one 15 min period  it will show 4.

What I am trying to achieve is to track how many employees and veterans I pick up in my shuttle bus at each of my shuttle stops.

Thanks for your help.

Phil

best response confirmed by Phil Cox (New Contributor)
Solution

@Phil Cox 

Near the end of the macro, change the part

    With wsData.Cells(r, TimeCol + x)
        .Value = 1
        .Interior.Color = vbYellow
    End With

to

    With wsData.Cells(r, TimeCol + x)
        .Value = .Value + 1
        .Interior.Color = vbYellow
    End With

And near the beginning, the line

    If Time > TimeSerial(18, 30, 0) And Time < TimeSerial(5, 30, 0) Then

should be

    If Time > TimeSerial(18, 30, 0) Or Time < TimeSerial(5, 30, 0) Then

See the attached version with the modified version of Subodh_Tiwari_sktneer's code.

@Hans Vogelaar 

Thanks for pointing out the error in logical condition and thanks for tweaking the code. That was a silly mistake, my bad.

You're welcome @Phil Cox! Got stuck in a project so couldn't reply in time but I am glad @Hans Vogelaar tweaked it for you.