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

Question

我一直在开发一个自动打开XML文件的VBA脚本，我需要解析我需要的数据。该脚本在Book1的顶部打开一个Book2窗口，并运行到开始从E列获取数据并将数据移至新表格的点。那时，我会得到一个应用程序运行时错误'1004'：应用程序定义或对象定义的错误。

我注意到Excel试图从Book1而不是Book2获取数据。谁能帮助我弄清楚自己出错的地方？在下面的脚本中创建所有床单之后，就会出现问题。谢谢

Sub ModifyUpdate()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb2 As Workbook 
Dim currentColumn As Integer
Dim columnHeading As String
ChDir Environ("USERPROFILE") & "Desktopmerged"
Set wb2 = Workbooks.OpenXML(Filename:= _
        Environ("USERPROFILE") & "Desktopmergedmerged_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") & "Desktopmerged"
    Set wb2 = Workbooks.OpenXML(Filename:= _
            Environ("USERPROFILE") & "Desktopmergedmerged_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