工作簿共享时VBAmacros不工作？

我有2个工作表：

工作表1：

Column E Column F Supplier 1 Supplier 2 

工作表2：

 Column A Column B Supplier 1 Jane Supplier 2 Mark 

我的代码在表2中列A的活动单元行的列E中查找供应商。

码：

 Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error GoTo Message 'Start Phone Book Directory Code Dim Contact As String Dim Email As String Dim Phone As String Dim Fax As String Application.EnableEvents = False 'to prevent endless loop On Error GoTo Finalize 'to re-enable the events If Intersect(Target, ThisWorkbook.Worksheets(1).Range("F" & ActiveCell.Row)) Is Nothing Then 'Main IF ActiveSheet.Shapes("Suggest").Visible = False ActiveSheet.Shapes("Close").Visible = False ActiveSheet.Unprotect Password:="SecretPassword" Else If ThisWorkbook.Worksheets(1).Range("E" & ActiveCell.Row).Value = "" Or ThisWorkbook.Worksheets(1).Range("F" & ActiveCell.Row).Value <> "" Then ' Secondary iF ActiveSheet.Shapes("Suggest").Visible = False ActiveSheet.Shapes("Close").Visible = False ActiveSheet.Unprotect Password:="SecretPassword" Else 'Start FIND With Worksheets("Contacts").Range("A1:A1000") Set c = .Find("*" & ActiveCell.Offset(0, -1).Value & "*", LookIn:=xlValues) If c Is Nothing Then 'Introduce FailSafe, escape code if no result found ActiveSheet.Shapes("Suggest").Visible = False ActiveSheet.Shapes("Close").Visible = False ActiveSheet.Unprotect Password:="SecretPassword" Else 'Check values are not blank If c.Offset(0, 1).Value <> "" Then Contact = "Contact: " & c.Offset(0, 1).Value & vbNewLine Else Contact = "" End If If c.Offset(0, 2).Value <> "" Then Email = "Email: " & c.Offset(0, 2).Value & vbNewLine Else Email = "" End If If c.Offset(0, 3).Value <> "" Then Phone = "Phone: " & c.Offset(0, 3).Value & vbNewLine Else Phone = "" End If If c.Offset(0, 4).Value <> "" Then Fax = "Fax: " & c.Offset(0, 4).Value Else Fax = "" End If 'Show Contacts ActiveSheet.Shapes("Suggest").TextFrame.Characters.Text = "Hello," & vbNewLine & vbNewLine & "Have you tried to contact " & ActiveCell.Offset(0, -1).Value & " about your issue?" & vbNewLine & vbNewLine _ & Contact & Email & Phone & Fax ActiveSheet.Shapes("Suggest").TextFrame.AutoSize = True CenterShape ActiveSheet.Shapes("Suggest") RightShape ActiveSheet.Shapes("Close") ActiveSheet.Shapes("Suggest").Visible = True 'Show Close Button ActiveSheet.Shapes("Close").OnAction = "HideShape" ActiveSheet.Shapes("Close").Visible = True 'Protect sheet ActiveSheet.Protect Password:="SecretPassword", userinterfaceonly:=True ActiveSheet.Shapes("Suggest").Locked = True End If End With End If ' End Main If End If ' End Secondary If Finalize: Application.EnableEvents = True Exit Sub Message: Application.DisplayAlerts = False Exit Sub End Sub Public Sub CenterShape(o As Shape) o.Left = ActiveWindow.VisibleRange(1).Left + (ActiveWindow.VisibleRange.Width / 2 - o.Width / 2) o.Top = ActiveWindow.VisibleRange(1).Top + (ActiveWindow.VisibleRange.Height / 2 - o.Height / 2) End Sub Public Sub RightShape(o As Shape) o.Left = ActiveSheet.Shapes("Suggest").Left + (ActiveSheet.Shapes("Suggest").Width / 1.01 - o.Width / 1.01) o.Top = ActiveSheet.Shapes("Suggest").Top + (ActiveSheet.Shapes("Suggest").Height / 30 - o.Height / 30) End Sub 

这在工作簿不共享的情况下工作：

但是，当我共享工作簿时，代码不再有效。 请有人告诉我我要去哪里错了吗？

编辑：

如果我删除error handling，并启用事件，那么我得到这个错误：

Answer 1

您的代码基于Selection_Change 。 只有在application.enableevents设置为true的情况下才有效。 大概你应该看看这样的状态：

 Sub TestMe debug.print application.enableevents end sub 

如果是false ，则将其设置为true 。

Answer 2

我设法通过一些调整，让代码在共享工作簿中工作。 当然，我不得不牺牲自动调整形状的能力，但这不是世界末日。

我不得不把我的文本放在一个单元格中，并得到该单元格的值。

码：

 Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'On Error GoTo Message ActiveSheet.DisplayPageBreaks = False If Target.Address = "$O$2" Then If Range("A" & Rows.Count).End(xlUp).Row < 5 Then Range("A5").Select Else Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select End If End If If Target.Address = "$N$2" Then If Range("A" & Rows.Count).End(xlUp).Row < 5 Then Range("A5").Select Else Range("A7").Select End If End If 'On Error GoTo Message: If Target.Address = "$D$4" Then UserForm1.show End If 'Start Phone Book Directory Code Dim Contact As String Dim Email As String Dim Phone As String Dim Fax As String Application.EnableEvents = False 'to prevent endless loop 'On Error GoTo Finalize 'to re-enable the events If Intersect(Target, ThisWorkbook.Worksheets(1).Range("F" & ActiveCell.Row)) Is Nothing Then 'Main IF ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = False ThisWorkbook.Worksheets(1).Shapes("Close").Visible = False 'ActiveSheet.Unprotect Password:="SecretPassword" Else If ThisWorkbook.Worksheets(1).Range("E" & ActiveCell.Row).Value = "" Or ThisWorkbook.Worksheets(1).Range("F" & ActiveCell.Row).Value <> "" Then ' Secondary iF ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = False ThisWorkbook.Worksheets(1).Shapes("Close").Visible = False 'ActiveSheet.Unprotect Password:="SecretPassword" Else 'Start FIND With Worksheets("Contacts").Range("A1:A10000") Set c = .Find("*" & ActiveCell.Offset(0, -1).Value & "*", LookIn:=xlValues) If c Is Nothing Then 'Introduce FailSafe, escape code if no result found ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = False ThisWorkbook.Worksheets(1).Shapes("Close").Visible = False 'ActiveSheet.Unprotect Password:="SecretPassword" Else 'Check values are not blank If c.Offset(0, 1).Value <> "" Then Contact = "Contact: " & c.Offset(0, 1).Value & vbNewLine Else Contact = "" End If If c.Offset(0, 2).Value <> "" Then Email = "Email: " & c.Offset(0, 2).Value & vbNewLine Else Email = "" End If If c.Offset(0, 3).Value <> "" Then Phone = "Phone: " & c.Offset(0, 3).Value & vbNewLine Else Phone = "" End If If c.Offset(0, 4).Value <> "" Then Fax = "Fax: " & c.Offset(0, 4).Value Else Fax = "Fax: No Fax Held" End If 'Show Contacts ThisWorkbook.Worksheets("Data").Range("I2").Value = "Hello," & vbNewLine & vbNewLine & "Have you tried to contact " & ActiveCell.Offset(0, -1).Value & " about your issue?" & vbNewLine & vbNewLine _ & Contact & Email & Phone & Fax 'ThisWorkbook.Worksheets(1).Shapes("Suggest").TextFrame.AutoSize = True CenterShape ThisWorkbook.Worksheets(1).Shapes("Suggest") RightShape ThisWorkbook.Worksheets(1).Shapes("Close") ThisWorkbook.Worksheets(1).Shapes("Suggest").Visible = True 'Show Close Button 'ThisWorkbook.Worksheets(1).Shapes("Close").OnAction = "HideShape" ThisWorkbook.Worksheets(1).Shapes("Close").Visible = True 'Protect sheet 'ActiveSheet.Protect Password:="SecretPassword", userinterfaceonly:=True 'ActiveSheet.Shapes("Suggest").Locked = True End If End With End If ' End Main If End If ' End Secondary If Finalize: Application.EnableEvents = True Exit Sub Message: Application.DisplayAlerts = False Exit Sub End Sub Public Sub CenterShape(o As Shape) o.Left = ActiveWindow.VisibleRange(1).Left + (ActiveWindow.VisibleRange.Width / 2.3 - o.Width / 2.3) o.Top = ActiveWindow.VisibleRange(1).Top + (ActiveWindow.VisibleRange.Height / 2 - o.Height / 2) End Sub Public Sub RightShape(o As Shape) o.Left = ThisWorkbook.Worksheets(1).Shapes("Suggest").Left + (ThisWorkbook.Worksheets(1).Shapes("Suggest").Width / 1.01 - o.Width / 1.01) o.Top = ThisWorkbook.Worksheets(1).Shapes("Suggest").Top + (ThisWorkbook.Worksheets(1).Shapes("Suggest").Height / 30 - o.Height / 30) End Sub Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Message On Error Resume Next ActiveSheet.DisplayPageBreaks = False Application.ScreenUpdating = False Application.DisplayAlerts = False If Not Intersect(Target, Range("O:O")) Is Nothing And ActiveCell.Value <> "" Then If Target.Cells.Count < 4 Then 'Set up the objects required for Automation into lotus notes Dim Maildb As Object 'The mail database Dim UserName As String 'The current users notes name Dim MailDbName As String 'THe current users notes mail database name Dim MailDoc As Object 'The mail document itself Dim AttachME As Object 'The attachment richtextfile object Dim session As Object 'The notes session Dim EmbedObj As Object 'The embedded object (Attachment) Dim Ref As String Dim TrueRef As String Ref = Range("G" & (ActiveCell.Row)).Value If Ref = "WSM" Then TrueRef = "WES" Else If Ref = "NAY" Then TrueRef = "NAY" Else If Ref = "ENF" Then TrueRef = "ENF" Else If Ref = "LUT" Then TrueRef = "MAG" Else If Ref = "NFL" Then TrueRef = "NOR" Else If Ref = "RUN" Then TrueRef = "RUN" Else If Ref = "SOU" Then TrueRef = "SOU" Else If Ref = "SOU" Then TrueRef = "SOU" Else If Ref = "BRI" Then TrueRef = "BRI" Else If Ref = "LIV" Then TrueRef = "LIV" Else If Ref = "BEL" Then TrueRef = "BEL" End If End If End If End If End If End If End If End If End If End If End If Dim FindString As String Dim rng As Range FindString = Ref With Sheets("Data").Range("C2:C11") Set rng = .Find(What:=FindString, _ After:=.Cells(.Cells.Count), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not rng Is Nothing Then 'Start a session to notes Set session = CreateObject("Notes.NotesSession") 'Next line only works with 5.x and above. Replace password with your password 'Session.Initialize ("password") 'Get the sessions username and then calculate the mail file name 'You may or may not need this as for MailDBname with some systems you 'can pass an empty string or using above password you can use other mailboxes. UserName = session.UserName MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf" 'Open the mail database in notes Set Maildb = session.GETDATABASE("", MailDbName) If Maildb.IsOpen = True Then 'Already open for mail Else Maildb.OPENMAIL End If 'Set up the new mail document Set MailDoc = Maildb.CREATEDOCUMENT MailDoc.Principal = "Food Specials <mailto: [e-mail]>" MailDoc.ReplyTo = "[e-mail]" 'MailDoc.DisplaySent = "[e-mail]" 'MailDoc.iNetFrom = "[e-mail]" 'MailDoc.iNetPrincipal = "[e-mail]" MailDoc.Form = "Memo" MailDoc.sendto = "Supplychain-" & TrueRef & "@lidl.co.uk" MailDoc.subject = "LO Delivery Tracker: The status of your Issue has been updated." MailDoc.body = "Hello," & vbNewLine & vbNewLine & vbNewLine & "Ref: " & Range("A" & ActiveCell.Row).Value & " - " & Range("E" & ActiveCell.Row).Value & vbNewLine & vbNewLine & vbNewLine & "The status of your issue has changed. Please access the Delivery Tracker for more information." & vbNewLine & vbNewLine & vbNewLine & "Supplier: " & vbNewLine & Range("E" & ActiveCell.Row).Value & vbNewLine & vbNewLine & "Issue: " & vbNewLine & Range("H" & ActiveCell.Row).Value & vbNewLine & vbNewLine & "H/O Comments: " & vbNewLine & Range("L" & ActiveCell.Row).Value & vbNewLine & vbNewLine & "Status: " & vbNewLine & Range("O" & ActiveCell.Row).Value & vbNewLine & vbNewLine & vbNewLine & "This information was correct at the time of sending. If you have any questions or concerns, please contact head office food specials." & vbNewLine & vbNewLine & "Thank you and Kind regards/ Dankeschön und Mit freundlichen Grüßen," & vbNewLine & vbNewLine & "Food Specials Team" _ & vbNewLine & " " & vbNewLine 'Send the document MailDoc.PostedDate = Now() 'Gets the mail to appear in the sent items folder MailDoc.SEND 0, Recipient 'Clean Up Set Maildb = Nothing Set MailDoc = Nothing Set AttachME = Nothing Set session = Nothing Set EmbedObj = Nothing End If End With End If End If 'Prompt missed on sale If Not Intersect(Target, Range("O:O")) Is Nothing And ActiveCell.Value = "Issue Complete" Then If Target.Cells.Count < 4 Then MSG1 = MsgBox("Did Item Miss On-Sale?", vbYesNo, "Feedback") If MSG1 = vbYes Then Range("P" & ActiveCell.Row).Value = "Yes" Else Range("P" & ActiveCell.Row).Value = "No" End If Range("Q" & ActiveCell.Row).Value = Date - Range("A" & ActiveCell.Row).Value End If End If Application.ScreenUpdating = True Application.DisplayAlerts = True If ActiveWorkbook.MultiUserEditing Then 'Auto Save workbook If Not Intersect(Target, Me.Range("E4")) Is Nothing Then Application.DisplayAlerts = False ThisWorkbook.Save End If End If On Error GoTo Message If e.KeyCode = Keys.Delete Then 'Create log file Dim FF FF = FreeFile() SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt", vbNormal Open "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt" For Append As #FF Print #FF, Now() & " - " & Application.UserName & " deleted a line from the Delivery Tracker." Close #FF SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt", vbReadOnly End If If Not Intersect(Target, Target.Worksheet.Range("G:G")) Is Nothing Then If Target.Cells.Count < 5 Then FF = FreeFile() SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt", vbNormal Open "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt" For Append As #FF Print #FF, Now() & " - " & Application.UserName & " added a new issue to the Delivery Tracker." Close #FF SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt", vbReadOnly End If End If On Error GoTo Message Static lngRow As Long Dim rng1 As Range Set rng1 = ThisWorkbook.Names("RowMarker").RefersToRange If lngRow = 0 Then lngRow = rng1.Row Exit Sub End If If rng1.Row = lngRow Then Exit Sub If rng1.Row < lngRow Then FF = FreeFile() SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt", vbNormal Open "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt" For Append As #FF Print #FF, Now() & " - " & Application.UserName & " deleted a line from the Delivery Tracker." Close #FF SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt", vbReadOnly Else FF = FreeFile() SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt", vbNormal Open "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt" For Append As #FF Print #FF, Now() & " - " & Application.UserName & " added a line to the Delivery Tracker." Close #FF SetAttr "G:\WH DISPO\(3) PROMOTIONS\(18) LO Delivery Tracking\Reports\LogFile.txt", vbReadOnly End If lngRow = rng1.Row Exit Sub Message: Application.DisplayAlerts = False Exit Sub End Sub 

Answer 3

在共享工作簿中有一些你不能做的事情，比如改变你的代码尝试的保护或者更改图片或者对象。

请参阅此处的列表： https : //support.office.com/en-gb/article/Use-a-shared-workbook-to-collaborate-49b833c0-873b-48d8-8bf2-c1c59a628534?ui=en-US&rs= -GB＆广告= GB＆fromAR = 1