Create New Worksheet Containing Buttons, not by template

The_skinner

New Member
Joined
Jun 18, 2008
Messages
15
Hello there,<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p></o:p>
<o:p></o:p>
I'm trying to create a macro that creates new worksheets with buttons on them that have macros attached. I've been able to produce one worksheet with a button and macro, but when the function that copies the code is looped it crashes out of Excel.<o:p></o:p>
<o:p></o:p>
I realise that the usual method of doing this would be by templates, but this code will be run on other people's computers so the template wouldn’t exist in the location that i had specified (I think with my limited experience with VBA - Please correct me if I'm wrong). I've also tried to copy the page with the button on, but this takes too long (even with screenupdating = false) as there are many sheets to be created.<o:p></o:p>
<o:p></o:p>
This is a stripped down version of the code that I have created for the purpose of this forum. To recap, the function that creates a new page, with button, with macro attached works. It's when it's looped that it crashes out. I've stepped through the program, and it reaches the second message box, then it gives up on life. <o:p></o:p>
<o:p></o:p>
I realise that financial incentives might be against this forum's code of conduct, but i will make an online donation to a charity of your choice if you can help me fix this code as it is making me hate life. <o:p></o:p>
<o:p></o:p>
Rich (BB code):
Private Sub CommandButton1_Click()
Rich (BB code):
Dim testvar As Boolean
Dim i As Integer
Dim continue As Boolean
continue = True
i = 1
Do Until continue = False 'loop until there's nothing in column A
  MsgBox "loop restarted"
 
  Sheets("Data").Select
  Worksheets.Add().Name = (i)
  testvar = copyheader(i)
  MsgBox "yeah!"
 
  If i >= 10 Then
      Exit Do
  End If
  i = i + 1
Loop
End Sub
Function copyheader(i As Integer) As Boolean
 
 
  Dim Name As String
  Dim NName As String
  Dim myCmdObj As OLEObject, N%
 
  Sheets(i).Select
 
  ' Set the name for the button
  NName = "cmdAction0"
 
   ' Add button
  Set myCmdObj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
  Link:=False, DisplayAsIcon:=False, Left:=146.25, Top:=1.5, _
  Width:=570, Height:=22.5)
 
   ' Define buttons name
  myCmdObj.Name = NName
 
   ' Define buttons caption
  myCmdObj.Object.Caption = "Click for action"
 
   ' Inserts code for the button
  With ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
      N = .CountOfLines
      .InsertLines N + 1, "Private Sub cmdAction0_Click()"
      .InsertLines N + 2, "End Sub"
  End With
 
End Function

Thank-you for your time<o:p></o:p>
<o:p></o:p>
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
Welcome to the Board.

Couldn't you have a (template) sheet within your workbook, hidden if you want, and copy that?
 
Upvote 0
I've tried hiding a worksheet and copying that, but it takes too long.

Here's where my knowledge is behind, i thought it was only possible to have a template as a stand-alone file, not contained within a workbook

Thanks for your reply, this sounds like it could be the answer
 
Upvote 0
You do realize that dynamically inserting code will go against the "probable default" security settings of each separate user? You will have to manually, or somebody will have to manually, provide trusted access to the VBProject by way of: Tools, Macros, Security, Trusted Publishers, Trust Access to Visual Basic Project. If not the code will not event make it to the msgbox on other machines.

Does your code currently add the code procedure to the new worksheet?

In any case, run this and report back with the error...if any.

Code:
Private Sub CommandButton1_Click()
    Dim testvar As Boolean
    Dim i As Integer
    Dim continue As Boolean
    continue = True
    i = 1
    Do Until continue = False 'loop until there's nothing in column A
      MsgBox "loop restarted"
     
      Sheets("Data").Select
      Worksheets.Add().Name = (i)
      testvar = copyheader(i)
      MsgBox "yeah!"
     
      If i >= 10 Then
          Exit Do
      End If
      i = i + 1
    Loop
End Sub

Function copyheader(i As Integer) As Boolean
     Dim Name As String
     Dim NName As String
     Dim myCmdObj As OLEObject, N%
     
     On Error GoTo Err_copyheader
    
     Sheets(i).Select
    
     ' Set the name for the button
     NName = "cmdAction0"
    
      ' Add button
     Set myCmdObj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
     Link:=False, DisplayAsIcon:=False, Left:=146.25, Top:=1.5, _
     Width:=570, Height:=22.5)
    
      ' Define buttons name
     myCmdObj.Name = NName
    
      ' Define buttons caption
     myCmdObj.Object.Caption = "Click for action"
    
      ' Inserts code for the button
     With ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
         N = .CountOfLines
         .InsertLines N + 1, "Private Sub cmdAction0_Click()"
         .InsertLines N + 2, "End Sub"
     End With
     
Exit Function
Err_copyheader:
MsgBox Err.Description
 
End Function

I need to see your entire procedure. Especially the code that would be inserted in the new worksheet.

Also, you should try to use early-bound references when dynamically adding ole objects. ActiveSheet is a late-bound reference.

Post your code or go with the template idea...
 
Upvote 0
My first question would be - do you actually need buttons on each sheet? Can you use a toolbar? If you do need buttons, do they all run the same code? If so, I would use buttons from the Forms toolbar and set the OnAction property to a common routine rather than creating a Click event in each sheet.
 
Upvote 0
Hi there, To Right-Click:

I've tried running your code, which i'm greatful for, but no error code is outputted. Instead i am greeted with the "Microsoft office Excel has encountered a problem and needs to close... Please contact microsoft about this problem"

The full code to for my program is:
Code:
Private Sub CommandButton1_Click()
Dim copy_sht As String
Dim sht_exist As Boolean
Dim testvar As Boolean
Dim row As Long
Dim copy_row As Long
Dim paste_sht As String
Dim i As Integer
Dim continue As Boolean
continue = True
i = 9
ScreenUpdating = False
Do Until continue = False 'loop until there's nothing in column A
    'Sheets("Data").Select
    sht_exist = True
    copy_sht = "Data"
    copy_row = i
    
    
    If Sheets("Data").Range("F" & (i)).Value = "" Then
        continue = False
        Exit Do
    End If
    
    If Sheets("Data").Range("H" & (i)).Value = Sheets("Data").Range("I" & (i)).Value And Sheets("Data").Range("H" & (i)).Value <> 0 And Sheets("Data").Range("I" & (i)).Value <> 0 Then
        paste_sht = Range("H" & (i)).Value
        sht_exist = chk_sheet(paste_sht)
        If sht_exist = False Then
            Worksheets.Add().Name = (paste_sht)
            testvar = copyheader(paste_sht, copy_sht)
            
            
        End If
        
        row = xlLastRow(paste_sht)
        If row = 0 Then
            row = 1
        End If
           
        testvar = copyrow(row, copy_row, paste_sht, copy_sht)
        
    End If
    
    If Sheets("Data").Range("H" & (i)).Value <> Sheets("Data").Range("I" & (i)).Value Then 'if the ranges are different, but possibly empty
        
        If Sheets("Data").Range("H" & (i)).Value <> 0 Then 'checks that H isn't empty
            paste_sht = Range("H" & (i)).Value
            sht_exist = chk_sheet(paste_sht)
            If sht_exist = False Then
                Worksheets.Add().Name = (paste_sht)
                testvar = copyheader(paste_sht, copy_sht)
                
                
            End If
            row = xlLastRow(paste_sht)
            If row = 0 Then
                row = 1
            End If
           
            testvar = copyrow(row, copy_row, paste_sht, copy_sht)
        End If
        
        If Sheets("Data").Range("I" & (i)).Value <> 0 Then 'checks that I isn't empty
            paste_sht = Range("I" & (i)).Value
            sht_exist = chk_sheet(paste_sht)
            If sht_exist = False Then
                Worksheets.Add().Name = (paste_sht)
                testvar = copyheader(paste_sht, paste_sht)
                
                
            End If
        
            row = xlLastRow(paste_sht)
            If row = 0 Then
                row = 1
            End If
           
            testvar = copyrow(row, copy_row, paste_sht, copy_sht)
        End If
    End If
    i = i + 1
Loop
ScreenUpdating = True
Application.DisplayAlerts = False
Sheets(" ").Delete
Application.DisplayAlerts = True
End Sub
Function chk_sheet(paste_sht As String) As Boolean    'Check if a sheet exists
    
    Dim wSheet As Worksheet
    On Error Resume Next
    Set wSheet = Sheets(paste_sht)
        If wSheet Is Nothing Then 'Doesn't exist
           chk_sheet = False
        Else 'Does exist
           chk_sheet = True
        End If
End Function
 
Function xlLastRow(Optional paste_sht As String) As Long '    find the last populated row in a worksheet
      
   If sht_name = vbNullString Then xlLastRow = 0
   With Worksheets(paste_sht)
        On Error Resume Next
        xlLastRow = .Cells.Find("*", .Cells(1), xlFormulas, _
        xlWhole, xlByRows, xlPrevious).row
        xlLastRow = xlLastRow + 1
        If Err <> 0 Then xlLastRow = 0
    End With
     
End Function
Function copyrow(row As Long, copy_row As Long, paste_sht As String, copy_sht As String) As Boolean
 'Is passed the names of the sheets, the rows, and transfers the data
    Dim x As Long
    Dim y As Long
    x = copy_row
    y = row
    Sheets(copy_sht).Range("D" & x & ", F" & x & ", H" & x & ", I" & x & ", W" & x & ", X" & x & ", Y" & x & ", Z" & x & ", AA" & x & ", AB" & x & ", AC" & x & ", AD" & x & ", AE" & x & ", AF" & x & ", AG" & x & ", AH" & x & ", AI" & x & ", AJ" & x & ", AK" & x & ", AL" & x & ", AM" & x & ", AN" & x & ", AO" & x & ", AP" & x & ", AQ" & x).Copy
    Sheets(paste_sht).Select
    Sheets(paste_sht).Range("A" & y).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Function
Function copyheader(paste_sht As String, copy_sht As String) As Boolean
    
    Dim i As Long, Hght As Long
    Dim Name As String, NName As String
    Sheets(paste_sht).Select
     ' Set the button properties
    i = 0
    Hght = 305.25
     ' Set the name for the button
    NName = "cmdAction" & i
     ' Test if there is a button already and if so, increment its name
    For Each OLEObject In ActiveSheet.OLEObjects
        If Left(OLEObject.Name, 9) = "cmdAction" Then
            Name = Right(OLEObject.Name, Len(OLEObject.Name) - 9)
            If Name >= i Then
                i = Name + 1
            End If
            NName = "cmdAction" & i
            Hght = Hght + 27
        End If
    Next
     ' Add button
    Dim myCmdObj As OLEObject, N%
    Set myCmdObj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
    Link:=False, DisplayAsIcon:=False, Left:=52.5, Top:=Hght, _
    Width:=202.5, Height:=26.25)
     ' Define buttons name
    myCmdObj.Name = NName
     ' Define buttons caption
    myCmdObj.Object.Caption = "Click for action"
     ' Inserts code for the button
    With ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
        N = .CountOfLines
        .InsertLines N + 1, "Private Sub cmdAction0_Click()"
        .InsertLines N + 2, "Dim continue As Boolean"
        .InsertLines N + 3, "Dim x As Long"
        .InsertLines N + 4, "Dim y As Long"
        .InsertLines N + 5, "Dim mfg As String"
        .InsertLines N + 6, "Dim count As Integer"
        .InsertLines N + 7, "Dim sht As String"
        .InsertLines N + 8, "continue = True"
        .InsertLines N + 9, "x = 6"
        .InsertLines N + 10, "sht = ActiveSheet.Name"
        .InsertLines N + 11, "Do Until continue = False"
        .InsertLines N + 12, "  mfg = Sheets(sht).Range(""A"" & x)"
        .InsertLines N + 13, "  y = 9"
        .InsertLines N + 14, "  count = 0"
        .InsertLines N + 15, "  If mfg = """" Then"
        .InsertLines N + 16, "      Exit Do"
        .InsertLines N + 17, "  End If"
        .InsertLines N + 18, "  Do Until continue = False"
        .InsertLines N + 19, "  If Sheets(" & """Data""" & ").Range(" & """D""" & "& y) = mfg Then"
        .InsertLines N + 20, "      Sheets(sht).Range(" & """E""" & "& x & " & """:""" & "& " & """L""" & "& x).Copy"
        .InsertLines N + 21, "      Sheets(" & """Data""" & ").Select"
        .InsertLines N + 22, "      Sheets(" & """Data""" & ").Range(" & """W""" & "& y & " & """:""" & "& " & """AD""" & "& y).Select"
        .InsertLines N + 23, "      ActiveSheet.Paste"
        .InsertLines N + 24, "      Sheets(sht).Range(" & """N""" & "& x & " & """:""" & "& " & """R""" & "& x).Copy"
        .InsertLines N + 25, "      Sheets(" & """Data""" & ").Select"
        .InsertLines N + 26, "      Sheets(" & """Data""" & ").Range(" & """AF""" & "& y & " & """:""" & "& " & """AJ""" & "& y).Select"
        .InsertLines N + 27, "      ActiveSheet.Paste"
        .InsertLines N + 28, "      Sheets(sht).Range(" & """T""" & "& x & " & """:""" & "& " & """Y""" & "& x).Copy"
        .InsertLines N + 29, "      Sheets(" & """Data""" & ").Select"
        .InsertLines N + 30, "      Sheets(" & """Data""" & ").Range(" & """AL""" & "& y & " & """:""" & "& " & """AQ""" & "& y).Select"
        .InsertLines N + 31, "      ActiveSheet.Paste"
        .InsertLines N + 32, "      Exit Do"
        .InsertLines N + 33, "  End If"
        .InsertLines N + 34, "  If Sheets(" & """Data""" & ").Range(" & """D""" & " & y) = " & """" & """Then"
        .InsertLines N + 35, "      count = count + 1"
        .InsertLines N + 36, "  End If"
        .InsertLines N + 37, "  If count >= 10 Then"
        .InsertLines N + 38, "      MsgBox " & """There has been an error, some of the information you have entered may not be saved on the master AQ-Men database. Please save this workbook as usual, and contact IT services. This problem has arisen because there is an account on your list with an MFG-Pro number that does not match those on the main database."""
        .InsertLines N + 39, "      Exit Do"
        .InsertLines N + 40, "  End If"
        .InsertLines N + 41, "  y = y + 1"
        .InsertLines N + 42, "  Loop"
        .InsertLines N + 43, "  x = x + 1"
        .InsertLines N + 44, "  Loop"
        .InsertLines N + 45, "End Sub"
        .InsertLines N + 46, ""
        
    End With
    
    Sheets(copy_sht).Select
    Range("D3:D5,F3:F5,H3:H5,I3:I5,W3:z5,AA3:AD5,AE3:AJ5,AK3:AQ5").Copy
    Sheets(paste_sht).Select
    Sheets(paste_sht).Range("A3:B3").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
End Function

To make it easier to read, the code that gets created on the new sheet is:

Code:
Private Sub CommandButton1_Click()
Dim continue As Boolean
Dim x As Long
Dim y As Long
Dim mfg As String
Dim count As Integer
Dim sht As String
continue = True
x = 6
sht = ActiveSheet.Name
Do Until continue = False
    mfg = Sheets(sht).Range("A" & x)
    y = 9
    count = 0
    
    If mfg = "" Then
        Exit Do
    End If
    
    Do Until continue = False
        If Sheets("Data").Range("D" & y) = mfg Then
            Sheets(sht).Range("E" & x & ":" & "L" & x).Copy
            Sheets("Data").Select
            Sheets("Data").Range("W" & y & ":" & "AD" & y).Select
            ActiveSheet.Paste
            Sheets(sht).Range("N" & x & ":" & "R" & x).Copy
            Sheets("Data").Select
            Sheets("Data").Range("AF" & y & ":" & "AJ" & y).Select
            ActiveSheet.Paste
            Sheets(sht).Range("T" & x & ":" & "Y" & x).Copy
            Sheets("Data").Select
            Sheets("Data").Range("AL" & y & ":" & "AQ" & y).Select
            ActiveSheet.Paste
                      
            Exit Do
        End If
   
        If Sheets("Data").Range("D" & y) = "" Then
            count = count + 1
        End If
        
        If count >= 10 Then
            MsgBox "There has been an error, some of the information you have entered may not be saved on the master AQ-Men database. Please save this workbook as usual, and contact IT services. This problem has arisen because there is an account on your list with an MFG-Pro number that does not match those on the main database."
            Exit Do
        End If
        
        y = y + 1
    Loop
    x = x + 1
Loop
End Sub

Thanks for any light you can shed on this

On the security settings front, i've enquired with our IT guy here and he says that all the machines this will be sent out to are set to medium security, so i'm thinking it shouls be alright.

I'm pretty new to this stuff so i'll have to research the difference between early and late binding

Thanks for your advice
 
Upvote 0
To Rorya,

You make a good point, as the code will be the same on each sheet, but what do you mean by "a common routine" with reference to the main code above

If so, I would use buttons from the Forms toolbar and set the OnAction property to a common routine rather than creating a Click event in each sheet.

Thank-you for your time
 
Upvote 0
Before I dig into this, have you considered Rory's reply? It seems to be a better way to go...
Medium security will not provide access to the VBProject. This is not a categorical setting. The inherant danger is that virus scanners ignore string assignments when scanning for malicious code. With access to the VBProject, you can insert executable code by way of string assignments
 
Last edited by a moderator:
Upvote 0
You can create a routine in a standard module and call that from every button. But if they all do the same thing anyway, I would have thought a toolbar was easier.
As regards the medium macro security, that is not the same thing as having access to the Visual Basic project trusted (which applies from XL2002 onwards). You can set that in code if the users have sufficient privileges.
 
Upvote 0
If there's an easier way to do this then i'll not just consider it, i'll do it. The only problem is that i'm maxed out on my skill level and don't really understand how his method will work.

I'm guessing that by "common routine" he means like on the closure of the workbook? That could work... I just worry that the code may not be executed properly if left till this event. Such as, will the macro be run if the user shuts down his computer, without closing Office. I don't want to seem like a stick in the mud, but this program is being written for people with a presumed skill level of none, so this program will have to hold their hand for everything.
 
Upvote 0

Forum statistics

Threads
1,213,562
Messages
6,114,326
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top