Excel 加载项未执行调用函数

Question

我有一个共享点网站，我使用 vba 上传新数据。我创建了一个 Excel 插件，我们将把它部署到其他用户，以便任何人都可以上传。

Excel插件由两个模块组成。第一个模块是“功能”模块，第二个是在插件上按下按钮时运行的代码。如果我用普通的 Excel 宏工作簿测试所有这些，它会完美运行。但是，当我在插件功能中对其进行测试时，“调用 SaveChanges”部分不起作用。

有谁知道是什么导致这部分不起作用？我什至尝试在插件上为 SaveChanges 部分添加另一个按钮，但仍然无法作为插件使用。

它调用的 SaveChanges Sub 将数据保存回 sharepoint。

模块 1

Option Explicit
Sub link_edit_Mode()
    
    Dim mySh As Worksheet
    Dim spSite As String
    
    Set mySh = Sheets("Sheet1")
    
    Dim src(0 To 1) As Variant
    
    spSite = "https://share.websitehere.com/sites/sitename/" 'site name
    src(0) = spSite & "/_vti_bin"
    
    src(1) = "{00000000-8F5B-4736-B48F-337D350E18C1}" 'GUID
    
    mySh.ListObjects.Add xlSrcExternal, src, True, xlYes, mySh.Range("A1")
    
End Sub

Sub SaveChanges()

   Dim mySh As Worksheet
   Dim lstOBJ As ListObject

   On Error GoTo errhdnler
   
   Set mySh = Sheets("Sheet1")
   Set lstOBJ = mySh.ListObjects(1)
   
   lstOBJ.UpdateChanges xlListConflictDialog
   
   Set mySh = Nothing
   Set lstOBJ = Nothing
   
Exit Sub
errhdnler:

Debug.Print Err.Description & Err.Number

End Sub

Sub refresh_Con()

   Dim mySh As Worksheet
   Dim lstOBJ As ListObject

On Error GoTo errhdnler

   Set mySh = Sheets("Sheet1")
   
   Set lstOBJ = mySh.ListObjects(1)
   
   lstOBJ.Refresh
  
   Set mySh = Nothing
   Set lstOBJ = Nothing
   
Exit Sub

errhdnler:

Debug.Print Err.Description & Err.Number

End Sub

第 2 单元

Sub FollowUps(control As IRibbonControl)
'
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Dim wsCopy As Worksheet
Dim wsDest As Worksheet

Rows("1:5").Select
Range("A5").Activate
Selection.Delete Shift:=xlUp
Columns("H:H").EntireColumn.AutoFit
Columns("I:I").EntireColumn.AutoFit

Sheets.Add.Name = "Sheet1"

' Worksheets("Sheet1").Visible = True

Call link_edit_Mode

Do While (Selection.Offset(1, 0) <> "")
   Range("A3").Select
   Selection.ListObject.ListRows(1).Delete
Selection.Offset(1, 0).Select
Range("A2").Select

Loop

'Set variables for copy and destination sheets
Set wsCopy = Workbooks("SA_Follow_Ups.xlsx").Worksheets("Follow Ups OpenUnresolved Over")
Set wsDest = Workbooks("SA_Follow_Ups.xlsx").Worksheets("Sheet1")

'1. Find last used row in the copy range based on data in column A
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row

'2. Find first blank row in the destination range based on data in column A
'Offset property moves down 1 row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(0).Row

'3. Copy & Paste Data
wsCopy.Range("A2:I" & lCopyLastRow).copy
wsDest.Range("B" & lDestLastRow).PasteSpecial xlValues

Call SaveChanges

ActiveWindow.SelectedSheets.Visible = False

End Sub

Answer 1

如果您将代码用作加载项，则需要指定您不再希望将某些内容保存在加载项本身的 sheet 中，而是保存在 sheet ActiveWorkbook 的。

所以你需要添加几行：

Dim wb As Workbook
Set wb = Application.ActiveWorkbook
Set mySh= wb.Sheets("Sheet1")

Answer 2

所以我想通了。

Sub SaveChanges()

   Dim mySh As Worksheet
   Dim objListObj As ListObject

   On Error GoTo errhdnler
   
   Set mySh = ActiveWorkbook.Worksheets("Sheet1")
   Set objListObj = mySh.ListObjects("Table1")
   
   objListObj.UpdateChanges xlListConflictDialog
   
   Set mySh = Nothing
   Set objListObj = Nothing
   
Exit Sub
errhdnler:

Debug.Print Err.Description & Err.Number

End Sub

Excel 加载项未执行调用函数

Excel Addin not executing Call Function

excel

vba

excel-addins