Question

我一直在研究一个自动打开XML文件的VBA脚本，并从中解析出我需要的数据。该脚本在book1顶部打开book2窗口并运行，直到它开始从列E中获取数据并将该数据移动到新工作表。那时我得到一个应用程序运行时错误＆＃39; 1004＆＃39;应用程序定义或对象定义错误。

我注意到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") & "\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

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

1 个答案: