Button code for module

[jrgsea]

Hi legends!

I'm trying to code a button that allows you to take the contents of one cell (that will be a time unit - hh:mm, let's say, cell F12) and add it to a range of cells that you define in another cell (say H12).

Could anyone help me with this??

Thank you all for you awesome help!

 

[mikerickson]

What might an entry in H12 look like?

Is this a short cut for PasteSpecial > addition ?

 

[jrgsea]

Well we could make it look like anything at this stage. The idea being that the user would insert the value into F12 to be added, and the range it is applicable to into H12. So, I guess H12=C12:C36 or H12="C12:C36".
Or as you recommend.

Thanks for the reply!

 

[mikerickson]

Try this. The user will select the destination range from the mouse.

Sub test()
    Dim uiRange As Range
    Dim strPrompt As String, strDefault
    
    strPrompt = "Select a range."
    strPrompt = strPrompt & vbCr & "The time in F12 will be added to each cell in this range."
    If TypeName(Selection) = "Range" Then strDefault = Selection.Address(,,,True)
    
    On Error Resume Next
        Set uiRange = Application.InputBox(strPrompt, Default:=strDefault, Type:=8)
    On Error GoTo 0
    If uiRange Is Nothing Then Exit Sub: Rem cancel pressed
    
    Range("F12").Copy
    uiRange.PasteSpecial Paste:=xlAll, Operation:=xlAdd, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
End Sub

 

[jrgsea]

Thanks mikerickson!

The only problem is it seems to copy the formatting from F12 to that range as well.

Otherwise selecting the range with the mouse is a great touch!

 

[mikerickson]

Try this, untested

Sub test()
    Dim uiRange As Range
    Dim strPrompt As String, strDefault
    
    strPrompt = "Select a range."
    strPrompt = strPrompt & vbCr & "The time in F12 will be added to each cell in this range."
    If TypeName(Selection) = "Range" Then strDefault = Selection.Address(,,,True)
    
    On Error Resume Next
        Set uiRange = Application.InputBox(strPrompt, Default:=strDefault, Type:=8)
    On Error GoTo 0
    If uiRange Is Nothing Then Exit Sub: Rem cancel pressed
    
    Range("F12").Copy
    uiRange.PasteSpecial Paste:=[COLOR="#FF0000"]xlValues[/COLOR], Operation:=xlAdd, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
End Sub

 

[jrgsea]

Thanks again, mikerson!

I actually made that change myself and it worked! Thanks for your help.

Have a good day mate.