移动数据并打开2个工作簿时出现VBA运行时错误

我一直在研究一个VBA脚本，它自动打开一个XML文件，并parsing我所需要的数据。 该脚本在book1顶部打开一个book2窗口并运行，直到它开始从列E抓取数据并将该数据移动到新的工作表。 在那一点上，我得到一个应用程序运行时错误“1004”：应用程序定义或对象定义的错误。

我注意到Excel正试图从book1而不是book2中获取数据。 任何人都可以帮助我找出错误的地方吗？ 在下面的脚本中创build所有工作表之后，就会出现问题。 谢谢

Sub ModifyUpdate() Application.ScreenUpdating = False Application.DisplayAlerts = False Dim wb2 As Workbook Dim currentColumn As Integer Dim columnHeading As String ChDir Environ("USERPROFILE") & "\Desktop\merged" Set wb2 = Workbooks.OpenXML(Filename:= _ Environ("USERPROFILE") & "\Desktop\merged\merged_final.xml", _ LoadOption:=xlXmlLoadImportToList) ActiveSheet.Columns("L").Delete For currentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1 columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value 'CHECK WHETHER TO KEEP THE COLUMN Select Case columnHeading Case "name6", "port", "svc_name", "protocol", "port", "pluginID8", "plugin_name", "agent", "plugin_output" 'Do nothing Case Else 'Delete if the cell doesn't contain "112" If InStr(1, _ ActiveSheet.UsedRange.Cells(1, currentColumn).Value, _ "112", vbBinaryCompare) = 0 Then ActiveSheet.Columns(currentColumn).Delete End If End Select Next Dim i As Long ActiveSheet.UsedRange.Select 'Deletes the entire row within the selection if the ENTIRE row contains no data. 'Work backwards because we are deleting rows. For i = Selection.Rows.Count To 1 Step -1 If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then Selection.Rows(i).EntireRow.Delete End If Next i wb2.Sheets.Add After:=Sheets(Sheets.Count) wb2.Sheets("Sheet2").Select wb2.Sheets("Sheet2").Name = "PPS" wb2.Sheets.Add After:=Sheets(Sheets.Count) wb2.Sheets("Sheet3").Select wb2.Sheets("Sheet3").Name = "NIX_SW" wb2.Sheets.Add After:=Sheets(Sheets.Count) wb2.Sheets("Sheet4").Select wb2.Sheets("Sheet4").Name = "WIN_SW" wb2.Sheets.Add After:=Sheets(Sheets.Count) wb2.Sheets("Sheet5").Select wb2.Sheets("Sheet5").Name = "OS_Type" wb2.Sheets.Add After:=Sheets(Sheets.Count) wb2.Sheets("Sheet6").Select wb2.Sheets("Sheet6").Name = "WEB" wb2.Sheets("Sheet1").Select For Each Cell In wb2.Sheets("Sheet1").Range("E:E") If Cell.Value = "10107" Then matchRow = Cell.Row Rows(matchRow & ":" & matchRow + 1).Select Selection.Copy wb2.Sheets("WEB").Select lastRow = ActiveSheet.UsedRange.Rows.Count If lastRow > 1 Then lastRow = lastRow + 1 ActiveSheet.Range("A" & lastRow).Select ActiveSheet.Paste wb2.Sheets("Sheet1").Select End If Next Application.ScreenUpdating = False Application.DisplayAlerts = False End Sub 

Answer 1

尝试这个

  Sub ModifyUpdate() Application.ScreenUpdating = False Application.DisplayAlerts = False Dim wb2 As Workbook Dim currentColumn As Integer Dim columnHeading As String ChDir Environ("USERPROFILE") & "\Desktop\merged" Set wb2 = Workbooks.OpenXML(Filename:= _ Environ("USERPROFILE") & "\Desktop\merged\merged_final.xml", _ LoadOption:=xlXmlLoadImportToList) ActiveSheet.Columns("L").Delete For currentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1 columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value 'CHECK WHETHER TO KEEP THE COLUMN Select Case columnHeading Case "name6", "port", "svc_name", "protocol", "port", "pluginID8", "plugin_name", "agent", "plugin_output" 'Do nothing Case Else 'Delete if the cell doesn't contain "112" If InStr(1, _ ActiveSheet.UsedRange.Cells(1, currentColumn).Value, _ "112", vbBinaryCompare) = 0 Then ActiveSheet.Columns(currentColumn).Delete End If End Select Next Dim i As Long 'Deletes the entire row within the selection if the ENTIRE row contains no data. 'Work backwards because we are deleting rows. For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 If WorksheetFunction.CountA(ActiveSheet.UsedRange.Rows(i)) = 0 Then ActiveSheet.UsedRange.Rows(i).EntireRow.Delete End If Next i wb2.Sheets.Add(after:=Sheets(Sheets.Count)).Name = "PPS" wb2.Sheets.Add(after:=Sheets(Sheets.Count)).Name = "NIX_SW" wb2.Sheets.Add(after:=Sheets(Sheets.Count)).Name = "WIN_SW" wb2.Sheets.Add(after:=Sheets(Sheets.Count)).Name = "OS_Type" wb2.Sheets.Add(after:=Sheets(Sheets.Count)).Name = "WEB" For Each Cell In wb2.Sheets("Sheet1").Range("E1", wb2.Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp)) If Cell.Value = "10107" Then matchRow = Cell.Row lastRow = wb2.Sheets("WEB").Range("A" & Rows.Count).End(xlUp).Row + 1 wb2.Sheets("Sheet1").Rows(matchRow & ":" & matchRow + 1).Copy wb2.Sheets("WEB").Range("A" & lastRow) End If Next Application.ScreenUpdating = False Application.DisplayAlerts = False End Sub