我最近在单击自定义功能区快捷方式（运行几个宏）时遇到此问题
代码涉及打开，保存，关闭，删除工作簿，通过API下载和解析XML数据，以及复制和复制其他工作簿
Description: A problem caused this program to stop interacting with Windows.
Problem signature:
Problem Event Name: AppHangB1
Application Name: EXCEL.EXE
Application Version: 15.0.4420.1017
Application Timestamp: 506741b5
Hang Signature: 6acb
Hang Type: 0
OS Version: 6.1.7601.2.1.0.256.1
Locale ID: 1037
Additional Hang Signature 1: 6acb5e8afc59fd5d0f16b73953ad555b
Additional Hang Signature 2: 94d6
Additional Hang Signature 3: 94d63882b3db19ba84c338ce0a96f1fe
Additional Hang Signature 4: 6acb
Additional Hang Signature 5: 6acb5e8afc59fd5d0f16b73953ad555b
Additional Hang Signature 6: 94d6
Additional Hang Signature 7: 94d63882b3db19ba84c338ce0a96f1fe
Read our privacy statement online:
http://go.microsoft.com/fwlink/?linkid=104288&clcid=0x0409
If the online privacy statement is not available, please read our privacy statement offline:
C:\Windows\system32\en-US\erofflps.txt
上面的错误几乎每次我打开工作簿并在Windows启动后第一次运行代码时都会发生。它导致Excel崩溃，然后我重新打开工作簿，重新运行代码，错误不再发生。但是下次我重新启动PC时会发生这种情况，等等。
在我对代码进行了一些改进并添加了一些更多的宏（通过单击自定义功能区按钮来运行所有宏）之后的一周内，我才开始收到这些错误。
Problem signature: Problem Event Name: APPCRASH
Application Name: EXCEL.EXE
Application Version: 15.0.4420.1017
Application Timestamp: 506741b5
Fault Module Name: VBE7.DLL
Fault Module Version: 7.1.10.38
Fault Module Timestamp: 4fea3eec
Exception Code: c0000005
Exception Offset: 00000000000412fc
OS Version: 6.1.7601.2.1.0.256.1
Locale ID: 1037
Additional information about the problem:
LCID: 1033
skulcid: 1037
上面的错误发生在几天前，由于某种原因，我不会再犯这个错误了，但我想它可能会告诉问题在哪里？
在我对代码进行了一些改进并添加了一些更多的宏之后，我才开始在过去一周内遇到这个问题（所有这些都是通过点击自定义功能区按钮来运行的）
我的代码可能有什么问题，或者它与Excel设置有什么关系？或者我怎么知道我的代码中的哪一行触发了错误？
修改
以下是所要求的VBA代码
单击快速访问工具栏中的按钮会触发以下子项：
Sub ImportToSales()
Application.ScreenUpdating = False
Workbooks.Open ("E:\eBay.xlsb")
Application.Run "eBay.xlsb!GetOrders"
Application.Run "eBay.xlsb!CopyToSales"
Application.ScreenUpdating = True
Application.DisplayAlerts = False
End Sub
GetOrders：（通过API下载并解析新订单数据）
Sub GetOrders()
Sheets("copy").Activate
Application.DisplayAlerts = False
On Error GoTo ErrHandle
Dim body As String: body = "..."
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
URL = "" 'API URL
objHTTP.Open "POST", URL, False
objHTTP.setRequestHeader "" 'Request Headers
objHTTP.send (body)
Set objXML = New MSXML2.DOMDocument
objXML.async = False
objXML.LoadXML (ConvertFromUTF8(objHTTP.ResponseText)) 'Calls a function to convert encoding
Set objXSL = New MSXML2.DOMDocument
objXSL.async = False
objXSL.Load "E:\RemoveAccent.xsl" 'Changes accented chars to regular chars
' TRANSFORMING objXML to newXML
Set newXML = New MSXML2.DOMDocument
objXML.transformNodeToObject objXSL, newXML
' NOTICE newXML REFERENCES
XmlNamespaces = "xmlns:doc='urn:ebay:apis:eBLBaseComponents'"
newXML.setProperty "SelectionNamespaces", XmlNamespaces
newXML.setProperty "SelectionLanguage", "XPath"
Dim xItemList As IXMLDOMNodeList
Set xItemList = newXML.DocumentElement.SelectNodes("//doc:Transaction")
Dim xItem As IXMLDOMNode
Dim copy As Worksheet
Set copy = Worksheets("copy")
Application.DisplayAlerts = False
Dim SalesWS As Worksheet
Dim SalesLR As Integer
Set SalesWS = Workbooks("Sales.xlsm").Worksheets("Sales")
SalesLR = Workbooks("Sales.xlsm").Worksheets("Sales").Cells(Rows.Count, "B").End(xlUp).Row
Row = 1
For Each xItem In xItemList
'Calls function to check if order exists in master sheet; If not then proceed
If CheckExist(xItem.SelectSingleNode("descendant::doc:TransactionID").Text, SalesWS, SalesLR) = False Then
copy.Cells(Row, 1) = xItem.SelectSingleNode("ancestor::doc:Order/descendant::doc:BuyerUserID").Text
copy.Cells(Row, 2) = xItem.SelectSingleNode("ancestor::doc:Order/descendant::doc:ShippingAddress/doc:Name").Text
Row = Row + 1
End If
Next
'If no new orders then end operation
If Row = 1 Then
Workbooks("Sales.xlsm").Activate
MsgBox "There are no new orders to import.", vbInformation
ThisWorkbook.Close
End If
Set objHTTP = Nothing
Set objXML = Nothing
'sort rows by Order Date
Columns("A:AO").Select
Selection.Sort Key1:=Range("Y2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("paste").Activate
PRtoUSA 'Replace "Puerto Rico" with "USA"
Exit Sub
ErrHandle:
' MISSING NODE ERROR
If Err.Number = 91 Then
Resume Next
' ALL OTHER ERRORS
Else:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Exit Sub
End If
End Sub
CopyToSales：（将下载和转换的数据复制到母版）
Sub CopyToSales()
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
Dim Sales As Workbook
Dim Orders As Workbook
Dim SalesSh As Worksheet
Dim OrdersSh As Worksheet
Dim eBay As Workbook
Dim copy As Worksheet
Dim paste As Worksheet
Workbooks.Open ("E:\Orders.xlsx")
Set Sales = Workbooks("Sales.xlsm")
Set SalesSh = Sales.Worksheets("sales")
Set Orders = Workbooks("Orders.xlsx")
Set OrdersSh = Orders.Worksheets("Orders")
Set eBay = Workbooks("eBay.xlsb")
Set copy = eBay.Worksheets("copy")
Set paste = eBay.Worksheets("paste")
Dim DataLr As Long
Dim SalesLR As Long
Dim OrdersLr As Long
'Set last rows
DataLr = copy.Range("A" & Rows.Count).End(xlUp).Row + 2
SalesLR = SalesSh.Range("A" & Rows.Count).End(xlUp).Row + 1
OrdersLr = OrdersSh.Range("A" & Rows.Count).End(xlUp).Row + 1
'Copy data to master sheet
paste.Rows("3:" & DataLr).copy
SalesSh.Range("A" & SalesLR).PasteSpecial xlPasteValues, SkipBlanks:=True
'Generate product pictures next to order number
SalesSh.Activate
Application.Run "Sales.xlsm!GeneratePictures"
SendKeys ("{ESC}")
SalesSh.Range("A1").Select
Application.CutCopyMode = False
'Generate order numbers
Dim i As Long
Dim J As Long
Dim LastOrder As Integer
Dim Multi As Boolean
SalesLR = SalesSh.Range("B" & Rows.Count).End(xlUp).Row
LastOrder = Split(Range("B" & SalesLR).value, "-")(0)
J = 1
i = SalesLR + 1
While Not IsEmpty(ActiveSheet.Range("H" & i))
If ActiveSheet.Range("H" & i) = ActiveSheet.Range("H" & i + 1) Then
Multi = True
While Multi = True
ActiveSheet.Range("B" & i) = LastOrder + 1 & "-" & J
J = J + 1
If ActiveSheet.Range("H" & i) = ActiveSheet.Range("H" & i + 1) Then
Multi = True
i = i + 1
Else
Multi = False
End If
Wend
LastOrder = LastOrder + 1
J = 1
Else
ActiveSheet.Range("B" & i) = LastOrder + 1
LastOrder = LastOrder + 1
End If
Application.CutCopyMode = False
i = i + 1
Wend
'Copy data to secondary sheet
OrdersSh.Activate
OrdersSh.Range("A1").Select
Application.CutCopyMode = False
SalesLR = SalesLR + 1
SalesSh.Range("A" & SalesLR & ":" & "S" & DataLr + SalesLR - 3).SpecialCells(xlCellTypeVisible).copy
OrdersSh.Range("A" & OrdersLr).Select
OrdersSh.paste
'Copy prices from secondary sheet to master sheet
SalesSh.Range("U" & SalesLR & ":" & "U" & SalesLR + DataLr - 3).copy
OrdersSh.Range("Q" & OrdersLr).PasteSpecial xlPasteValues
SalesSh.Range("U" & SalesLR & ":" & "U" & SalesLR + DataLr - 3).ClearContents
'Select last row in secondary sheet
SendKeys ("{ESC}")
OrdersSh.Range("B" & OrdersLr + DataLr - 3).Select
'Scroll to first row of new data in secondary sheet
ActiveWindow.ScrollRow = Selection.Row - DataLr + 3
ActiveWindow.ScrollColumn = Selection.Column
'Select last row in master sheet
SalesSh.Activate
SendKeys ("{ESC}")
SalesSh.Range("B" & SalesLR + DataLr - 3).Select
'Scroll to first row of new data in master sheet
SalesSh.Activate
ActiveWindow.ScrollRow = Selection.Row - DataLr + 3
ActiveWindow.ScrollColumn = Selection.Column
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Application.Run "Sales.xlsm!UploadPic" 'Copies product pictures of the new orders from master drive to backup drive
eBay.Saved = True
eBay.Close
End Sub