Assign macro to a format control button issue

[mysticmario]

Hi,
can someone tell me how to bypass this?
I have a template sheet for my projects summary. So everytime i create a new summary this template is copied as a new summary sheet. On this sheet I have few navigation and function buttons. The macros behind those buttons are stored on the template sheet itself, however when I copy the sheet the assigned macro tries to reffer to that template sheet instead of current sheet.
So let says I have a Arkusz22(Sheet22 in english) and template has a number 9. see below screenshot, where I have to manually change Arkusz9 to Arkusz22 in order to be able to execute the macro.
I know I can store the macro in a module, but the issue with that is, if i decide to copy this summary to a new workbook, I lose all the buttons functionality. Because whenever I click the button in new workbook it opens previous workbook to use this module with the macro which is not optimal to say the least. I also cannot use ActiveX buttons because this breaks co-authoring. Any ideas?

 

[cmowla]

Since you don't mind using buttons that are gray in color, you can use a sub that creates the buttons for you. So if you use this code, simply put in the required information for the buttons (the caption, the cell(s) that you want them to be placed on, which subs they call when clicked on, the desired font size, etc.). And of course, delete the old buttons from the template sheet. (And I see that the width of your buttons is wider than 1 cell. You can change C1 to C1:D1 if you want the button to be on two cells, etc.

Sub Your_Sub_That_Creates_New_Summary_Sheet_From_Template()

Dim sheetName As String
sheetName = "Your new summary sheet name"

Sheets(sheetName).Buttons.Delete 'Just in case.
Dim i As Integer
i = 0

i = i + 1
Call Create_Button(sheetName, "C1", "Przejdz do projektu", "The name of the sub [Przejdz do projektu] runs", i)
i = i + 1
Call Create_Button(sheetName, "D1", "Dodaj kolejny okres", "The name of the sub [Dodaj kolejny okres] runs", i)
i = i + 1
Call Create_Button(sheetName, "E1", "Drukuj ostatni okres", "The name of the sub [Drukuj ostatni okres] runs", i)
i = i + 1
Call Create_Button(sheetName, "F1", "<<WROC", "The name of the sub [<<WROC] runs", i)

End Sub

Sub Create_Button(sheetName As String, cellAddress As String, buttonText As String, macroNameToRun As String, indexx As Integer)
With Sheets(sheetName).Range(cellAddress)
    Dim btn As Button
    Set btn = Sheets(sheetName).Buttons.Add(.Left, .Top, .Width, .Height)
End With
With btn
    .Font.Size = 12
    .Font.Bold = True
    .Font.Name = "Calibri"
    .OnAction = macroNameToRun
    .Caption = buttonText
    .Name = sheetName & "_button_" & indexx
End With
End Sub

 

[mysticmario]

I need to go through your code, cause I have a specific way to create new summary sheet. I need to check if I can implement this solution, I will let you know how it went ASAP

 

[mysticmario]

This is what creates new project sheet

Sub nowy_Click()
Dim nazwaProjektu As String, adresProjektu As String, terminProjektu As String
Dim lr As Long
Dim number As Double
Randomize
number = Int((999 - Rnd) * Rnd + Rnd)
projectnumber = Format(number, "000")
data = Date
doubledigitdata = Format(Day(data), "00")


nazwaProjektu = InputBox("Podaj nazwę projektu", "Stwórz nowy projekt")
adresProjektu = InputBox("Podaj adres", "Stwórz nowy projekt")

terminProjektu = InputBox("Podaj ostateczną datę zakończenia projektu(DDMMRRRR)", "Stwórz nowy projekt")
Sheets("OTWARTE PROJEKTY").Unprotect
If Not nazwaProjektu = Empty Then
lr = Sheets("OTWARTE PROJEKTY").Cells(Rows.Count, "B").End(xlUp).Row
Sheets("OTWARTE PROJEKTY").Cells(lr + 1, "B").Value = projectnumber & doubledigitdata & " " & nazwaProjektu
lr = Sheets("OTWARTE PROJEKTY").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("OTWARTE PROJEKTY").Cells(lr + 1, "A").Value = Date
    If Not adresProjektu = Empty Then
    lr = Sheets("OTWARTE PROJEKTY").Cells(Rows.Count, "C").End(xlUp).Row
    Sheets("OTWARTE PROJEKTY").Cells(lr + 1, "C").Value = adresProjektu
    Else
    adresProjektu = "--"
    Sheets("OTWARTE PROJEKTY").Cells(lr + 1, "C").Value = adresProjektu
    End If
Else: Exit Sub
End If


lr = Sheets("OTWARTE PROJEKTY").Cells(Rows.Count, "D").End(xlUp).Row
If terminProjektu = Empty Then
Sheets("OTWARTE PROJEKTY").Cells(lr + 1, "D").Value = "N/D"
Else
Sheets("OTWARTE PROJEKTY").Cells(lr + 1, "D").Value = Format(terminProjektu, "DD.MM.YYY")
End If
    Range("A3:A500").Select
    ActiveWorkbook.Worksheets("OTWARTE PROJEKTY").sort.SortFields.Clear
    ActiveWorkbook.Worksheets("OTWARTE PROJEKTY").sort.SortFields.Add2 Key:=Range _
        ("A3:A200"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("OTWARTE PROJEKTY").sort
        .SetRange Range("A2:E500")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Call publish
Sheets("OTWARTE PROJEKTY").Protect
NowyProjekt.Show
End Sub

and this:
NowyProjekt=

Private Sub CreateNewForm_Click()
'FAKTURY
Dim ans As String
 ans = Me.OpenProjects.Value
 Sheets("Szablon faktury").Copy Before:=Sheets("END BLOCK")
 ActiveSheet.Name = "Faktury" + Left(ans, 5)
 Range("C3").Value = ans
'GODZINY

 Sheets("Szablon godziny").Copy Before:=Sheets("END BLOCK")
 ActiveSheet.Name = "Godziny" + Left(ans, 5)
 Range("C3").Value = ans
Sheets("OTWARTE PROJEKTY").Activate
 MsgBox ("Utworzono nowy projekt numer: " & Left(ans, 5))
Me.OpenProjects.Value = ""
Unload Me


End Sub

I need some spare time to implement your idea, but it seems good.

 

[mysticmario]

Alright I finally was able to get to this, I made necessary changes to implement it by I receive and error, maybe you can help ,me why.

And here is the final code I am using, it's still messy but most of the functionality has been achieved.

Private Sub CreateNewForm_Click()
'GODZINY'
Dim ans As String
Dim sheetName As String
Dim i As Integer
ans = Me.OpenProjects.Value
sheetName = "Godziny" + Left(ans, 5)
Sheets("Szablon godziny").Copy Before:=Sheets("END BLOCK")
ActiveSheet.Name = sheetName
Range("C3").Value = ans

i = 0
i = i + 1
Call Create_Button(sheetName, "C1:D1", "Przejdź do projektu", "WyszukajProjektG_Click", i)
i = i + 1
Call Create_Button(sheetName, "F1:G1", "Dodaj kolejny okres", "NewPage2_Click", i)
i = i + 1
Call Create_Button(sheetName, "I1:J1", "Drukuj ostatni okres", "printlastperiod_Click", i)
i = i + 1
Call Create_Button(sheetName, "L1:M1", "Zakończ projekt", "zakonczprojekt2_Click", i)
i = i + 1
Call Create_Button(sheetName, "O1:P1", "Podsumowanie projektu", "sumuj_Click", i)

'FAKTURY

ans = Me.OpenProjects.Value
sheetName = "Faktury" + Left(ans, 5)
Sheets("Szablon faktury").Copy Before:=Sheets("END BLOCK")
ActiveSheet.Name = sheetName
Range("C3").Value = ans

i = 0
i = i + 1
Call Create_Button2(sheetName, "C1:D1", "Przejdź do projektu", "WyszukajProjektF_Click", i)
i = i + 1
Call Create_Button2(sheetName, "F1:G1", "Dodaj kolejny okres", "NewPage_Click", i)
i = i + 1
Call Create_Button2(sheetName, "I1:J1", "Drukuj ostatni okres", "printlastperiod1_Click", i)
Me.OpenProjects.Value = ""
Unload Me
Sheets("OTWARTE PROJEKTY").Activate
 MsgBox ("Utworzono nowy projekt numer: " & Left(ans, 5))
End Sub

Sub Create_Button(sheetName As String, ans As String, cellAddress As String, buttonText As String, macroNameToRun As String, indexx As Integer)
ans = Me.OpenProjects.Value
 sheetName = "Godziny" + Left(ans, 5)
With Sheets(sheetName).Range(cellAddress)
    Dim btn As Button
    Set btn = Sheets(sheetName).Buttons.Add(.Left, .Top, .Width, .Height)
End With
With btn
    .Font.Size = 12
    .Font.Bold = True
    .Font.Name = "Calibri"
    .OnAction = macroNameToRun
    .Caption = buttonText
    .Name = sheetName & "_button_" & indexx
End With


End Sub
Sub Create_Button2(sheetName As String, ans As String, cellAddress As String, buttonText As String, macroNameToRun As String, indexx As Integer)
ans = Me.OpenProjects.Value
sheetName = "Faktury" + Left(ans, 5)
With Sheets(sheetName).Range(cellAddress)
    Dim btn As Button
    Set btn = Sheets(sheetName).Buttons.Add(.Left, .Top, .Width, .Height)
End With
With btn
    .Font.Size = 12
    .Font.Bold = True
    .Font.Name = "Calibri"
    .OnAction = macroNameToRun
    .Caption = buttonText
    .Name = sheetName & "_button_" & indexx
End With


End Sub

 

[RoryA]

You altered the Create_Button routine to take an additional String argument (ans) even though you populate it inside the routine. You should remove that argument.

 

[mysticmario]

You altered the Create_Button routine to take an additional String argument (ans) even though you populate it inside the routine. You should remove that argument.

I didn't really get it why but I did what you asked and expecteadly i get an variable not defined error, cause i need that variable for this routine.

 

[mysticmario]

Maybe that's what you meant? Move it below?

Sub Create_Button(sheetName As String, cellAddress As String, buttonText As String, macroNameToRun As String, indexx As Integer)
Dim ans As String
ans = ans = Me.OpenProjects.Value

 sheetName = "Godziny" + Left(ans, 5)
With Sheets(sheetName).Range(cellAddress)
    Dim btn As Button
    Set btn = Sheets(sheetName).Buttons.Add(.Left, .Top, .Width, .Height)
End With
With btn
    .Font.Size = 12
    .Font.Bold = True
    .Font.Name = "Calibri"
    .OnAction = macroNameToRun
    .Caption = buttonText
    .Name = sheetName & "_button_" & indexx
End With


End Sub

Guess I need to also declare value for cellAdresse, but whta woudl eb the adress for this particualr sub which creates button in few seperate locations?

 

[RoryA]

No, you are passing cellAddress to the sub each time, so that's fine.

 

[mysticmario]

Guess not - subscript out of range