Assigning a Macro to a Shape in another Macro

[tommyboy2340]

Hello, I am relatively new to coding in VBA. I am trying to make a code where it looks at a list of company names (That is dynamic), makes a shape (button) for every value in the list, assigns a name and a macro to each shape based on the list. I am able to get the shapes and the names on the shapes, however, the macros are not assigning to each shape. Each shape is supposed to filter a different list based on whatever the name of the company is (the name on the original list=shape name=filter name). I have attached my code, if anyone has any tips I would appreciate it!

Option Explicit

Public Sub ListContractors()

Dim Contractor As String, ContrID As String, ListName As String
Dim ContrName As String
Dim ContrCol As Long, ContrRow As Long, LastContrRow As Long
Dim ListRow As Long, ListCol As Long
Dim LastResultRow As Long, ResultRow As Long
Dim shp As Shape, i As Long

    Sheet1.Select
    LastContrRow = 999
    ListRow = 2
'Create list of Contractors
  Sheet3.Select
  ListName = "Georlia"
  LastContrRow = 999
  ListRow = 2
    For ContrRow = 2 To LastContrRow
    Contractor = Sheet3.Range("C" & ContrRow).Value
    If Contractor = "zzzz" Then
        GoTo NoContractors:
    ElseIf Contractor = "" Then
        GoTo NoContractors:
    ElseIf Contractor = ListName Then
        ContrRow = ContrRow
    ElseIf Contractor <> ListName Then Range("C" & ContrRow).Select
                Set shp = Sheet1.Shapes.AddShape(msoShapeRoundedRectangle, 275, 300 - i, 300, 25)
                i = i - 30
                ListName = Sheet3.Range("C" & ListRow).Value
                ListRow = ListRow + 1
            
                With shp
                    .TextFrame.Characters.Text = ListName
                    .TextFrame.Characters.Font.Bold = True
                    .Fill.Visible = msoTrue
                    .Fill.Transparency = 0#
                    .Line.Visible = msoFalse
                    .OnAction = "Macro"
                    Sheet3.Select
                End With
     End If

NoContractors:  Application.CutCopyMode = False
'Cont:   Worksheets("Table").Range("$AB$1:$AF$999").AutoFilter Field:=5, Criteria1:=Contractor
     Next ContrRow

    
End Sub

Public Sub Macro(Optional ByVal ListName As String)

Call ListContractors

ActiveWorkbook.Worksheets("Table").Range("$AB$1:$AF$999").AutoFilter Field:=5, Criteria2:=ListName
End Sub

 

[tommyboy2340]

If the script is the same for all company names.
And you want to use buttons.
Why not have the script in the button ask you what is the sheet name.

Or you can use a Combobox with all the sheet name and when you click on "Alpha"
The script would know the company name

No need to have 20 buttons if all the scripts are the same except for company names

If you want something like this I can write a script to do that.

That would be perfect!

 

[My Aswer Is This]

That would be perfect!

I know something like my suggestion would work but I'm not really familiar with auto filter.
I have to sign off I will try and be back later.
Or maybe someone else here will b able to help you.
Still not sure what you script does and its a very large range.

 

[My Aswer Is This]

Try this:
Since I do not have a range like you just try this in a button
The script asks for the company name

Sub My_Script()
'Modified 10/8/2021  2:52:49 PM  EDT
Application.ScreenUpdating = False
Dim Listname As String


Listname = InputBox("Enter the company name")
ActiveWorkbook.Worksheets("Table").Range("$AB$1:$AF$999").AutoFilter Field:=5, Criteria1:=Listname
Application.ScreenUpdating = True
End Sub

 

[tommyboy2340]

Try this:
Since I do not have a range like you just try this in a button
The script asks for the company name

Sub My_Script()
'Modified 10/8/2021  2:52:49 PM  EDT
Application.ScreenUpdating = False
Dim Listname As String


Listname = InputBox("Enter the company name")
ActiveWorkbook.Worksheets("Table").Range("$AB$1:$AF$999").AutoFilter Field:=5, Criteria1:=Listname
Application.ScreenUpdating = True
End Sub

Thats perfect! Thank you

 

[My Aswer Is This]

Thats perfect! Thank you

Wow we solved that question:
Glad I was able to help you.
Come back here to Mr. Excel next time you need additional assistance.