Excel VBA запускается, но не при назначении макроса

Question

У меня есть некоторый код VBA, который я запускаю в области VBA с зеленой кнопкой воспроизведения «Запустить Sub / UserForm», и он работает отлично. Однако я создаю Shape, а затем назначаю ему макрос, чтобы пользователь мог просто щелкнуть фигуру, но она не работает. В нем говорится: «Невозможно запустить макрос '' IMD Automation.xlsm '! IMDAutomation'. Макрос может быть недоступен в этой книге или все макросы могут быть отключены."

Я посмотрел вокруг и включил весь контент. Я создал новую книгу и скопировал весь код, но ничего.

Полный код ниже

Option Explicit

Public Sub IMDAutomation()
ThisWorkbook.Activate


Dim fileName As String 'Filename string

Dim wb_macro As Workbook 'Macro workbook
Dim ws_macro_imd As Worksheet 'Macro worksheet
Dim ws_macro_raw As Worksheet 'Macro raw worksheet
Dim wb_new As Workbook
Dim ws_new As Worksheet


Dim wb_imd As Workbook 'IMD Workbook for processing
Dim ws_imd As Worksheet 'IMD Worksheet for processing

Dim objTable As ListObject 'Table of raw data
Dim objTable2 As ListObject

Dim tbl_raw As ListObject 'Raw table in macro workbook
Dim tbl_imd As ListObject 'IMD table in macro workbook

Dim newRow As Range

Dim vals As Variant 'Array to store values

Dim lrow As Long 'Variable used to determine number of rows in data table

Set wb_macro = ThisWorkbook
Set ws_macro_imd = wb_macro.Sheets("IMD")
Set ws_macro_raw = wb_macro.Sheets("Raw")


'============ Initialize macro workbook - clearing data ============'
'Clear the raw data in the macro workbook
Set tbl_raw = ws_macro_raw.ListObjects("tbl_raw")
    With tbl_raw.DataBodyRange
           If .Rows.Count > 1 Then
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        End If
    End With
tbl_raw.DataBodyRange.Rows(1).ClearContents


'Clear the IMD data in the macro workbook
Set tbl_imd = ws_macro_imd.ListObjects("tbl_imd")
'    With tbl_imd.DataBodyRange
'        If .Rows.Count > 1 Then
'            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete ' Removed .Rows.Count-1
'        End If
'    End With


With tbl_imd
    If Not .DataBodyRange Is Nothing Then
        .DataBodyRange.Delete
    End If
End With
'tbl_imd.DataBodyRange.Rows(1).ClearContents
'tbl_imd.ListRows.Add


'============ Locate Raw Data File ============'
'Open file dialog to locate the Workforce Review raw data workbook exported from system
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .Title = "Select the IMD file"
    .Filters.Clear
    .Filters.Add "Custom Excel Files", "*.xlsx, *xls, *csv"
    .Show
    fileName = .SelectedItems.Item(1)
End With
If InStr(fileName, ".xlsx") = 0 Then
Exit Sub
End If
Workbooks.Open fileName
'Set the Workforce Review raw workbook
Set wb_imd = ActiveWorkbook
'Set the worksheet
Set ws_imd = wb_imd.ActiveSheet


lrow = ws_imd.Cells(ws_imd.Rows.Count, 2).End(xlUp).Row
ws_imd.Range("A1:CU" & lrow).Copy

'vals = ws_imd.Range("A2:CU" & lrow)

tbl_raw.Resize tbl_raw.Range.Resize(lrow - 1)

ws_macro_raw.Range("A1").PasteSpecial
'tbl_raw.DataBodyRange.Value = vals

Application.CutCopyMode = False
Application.CutCopyMode = True
wb_imd.Close

ws_macro_imd.Range("tbl_imd[ParNumber]").NumberFormat = "@"
ws_macro_imd.Range("tbl_imd[PersLine]").NumberFormat = "@"
ws_macro_imd.Range("tbl_imd[NTE Date]").NumberFormat = "yyyy-mm-dd"

Dim lc As Long, mc As Variant, x As Variant
With tbl_imd
        'clear target table
        On Error Resume Next
        .DataBodyRange.Clear
        .Resize .Range.Resize(tbl_raw.ListRows.Count + 1, .ListColumns.Count)
        On Error GoTo 0

        'loop through target header and collect columns from tbl_raw
        For lc = 1 To .ListColumns.Count
            Debug.Print .HeaderRowRange(lc)
            mc = Application.Match(.HeaderRowRange(lc), tbl_raw.HeaderRowRange, 0)
            If Not IsError(mc) Then
                x = tbl_raw.ListColumns(mc).DataBodyRange.Value
'                .ListColumns(lc).DataBodyRange.NumberFormat = "@"
                .ListColumns(lc).DataBodyRange = x
            End If
        Next lc

    End With


Set wb_new = Workbooks.Add
ActiveSheet.Name = "IMD Processed"
Set ws_new = ActiveSheet

tbl_imd.Range.Copy
ws_new.Range("A1").PasteSpecial xlPasteValues
Set objTable2 = ws_new.ListObjects.Add(xlSrcRange, Selection, xlYes)

Application.GetSaveAsFilename



End Sub

Любое руководство будет оценено.

Answer 1

Попробуйте добавить «Public» в «Sub» и активировать книгу:

Public Sub Automation()
    'Add this command line to activate your Excel Workbook
    ThisWorkbook.Activate

    '==============================
    '====    Your code here    ====
    '==============================
End Sub