excel - 当不包含来自 varLists 的值时删除列/行

Question

我是 VBA 新手...我正在尝试从 Sheet1:"Template" ROW1/headers 文件中删除与 varList:"ColumnsList" （即在 Sheet3 中）上的任何单元格值都不匹配的所有列。

如何选择标题或如何选择要搜索的第 1 行范围？

此外，我在这一行中有一个运行时错误 5：无效的过程调用或参数。

如果 Intersect(rng.Cells(1, i).EntireColumn, rngF) 什么都没有，那么

任何善良的灵魂可以帮助我吗？

另外，我需要做同样的事情，但使用 Sheet1:"Template" 中的行。我需要从 varList:"Agents" （即在 Sheet2 中）中删除任何不包含任何单元格值的行。

你能帮帮我吗？

预先感谢！

Option Compare Text
Sub ModifyTICBData()

Dim varList As Variant
    Dim lngarrCounter As Long
    Dim rngFound As Range, rngToDelete As Range
    Dim strFirstAddress As String

    'Application.ScreenUpdating = False

    varList = VBA.Array("ColumnsList") 'I want to keep columns with these values, NOT DELETE THEM

    For lngarrCounter = LBound(varList) To UBound(varList)

        With Sheets("Template").UsedRange
            Set rngFound = .Find( _
                                What:=varList(lngarrCounter), _
                                Lookat:=xlWhole, _
                                SearchOrder:=xlByColumns, _
                                SearchDirection:=xlNext, _
                                MatchCase:=True)

            If Not rngFound Is Nothing Then
                strFirstAddress = rngFound.Address

                If rngToDelete Is Nothing Then
                    Set rngToDelete = rngFound
                Else
                    If Application.Intersect(rngToDelete, rngFound.EntireColumn) Is Nothing Then
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                End If

                Set rngFound = .FindNext(After:=rngFound)

                Do Until rngFound.Address = strFirstAddress
                    If Application.Intersect(rngToDelete, rngFound.EntireColumn) Is Nothing Then
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                    Set rngFound = .FindNext(After:=rngFound)
                Loop
            End If
        End With
    Next lngarrCounter

    Dim rngDel As Range
Set rngDel = NotIntersectRng(Sheets("Template").UsedRange, rngToDelete)
If Not rngDel Is Nothing Then rngDel.EntireColumn.delete

    'Application.ScreenUpdating = True
End Sub

Private Function NotIntersectRng(rng As Range, rngF As Range) As Range
  Dim rngNI As Range, i As Long, j As Long
  For i = 1 To rng.Columns.Count
    **If Intersect(rng.Cells(1, i).EntireColumn, rngF) Is Nothing Then**
        If rngNI Is Nothing Then
            Set rngNI = rng.Cells(1, i)
        Else
            Set rngNI = Union(rngNI, rng.Cells(1, i))
        End If
    End If
  Next i
  If Not rngNI Is Nothing Then Set NotIntersectRng = rngNI
End Function

标签： excelvba

Answer 1

删除列，然后删除行

描述

• 删除第一行中不包含列表值的列。然后删除第一列中不包含另一个列表中的值的行。

流动

• 将范围内的值写入数组中A2的最后一个单元格。Sheet3Cols
• 将范围内的值写入数组中A2的最后一个单元格。Sheet2Agents
• 使用CurrentRegion定义DataSet Range( rng)。
• 从第 2 列开始循环遍历cel第一行中的单元格 ( )，并将它们的值与ColsArray 中的值进行比较。如果未找到，则将单元格添加到Delete Range( rngDel)。
• 最后删除“收集”的单元格的整个列。
• 从第 2 行开始循环遍历cel第一列中的单元格 ( )，并将它们的值与AgentsArray 中的值进行比较。如果未找到，则将单元格添加到Delete Range( rngDel)。
• 最后删除“收集”的单元格的整行。
• 通知用户成功或无操作。

编码

Option Explicit

Sub ModifyTICBData()

    ' Define workbook ('wb').
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Define Columns List ('Cols').
    Dim ws As Worksheet
    Set ws = wb.Worksheets("Sheet3")
    Dim rng As Range
    Set rng = ws.Cells(ws.Rows.Count, "A").End(xlUp)
    Dim Cols As Variant
    Cols = ws.Range("A2", rng).Value
    
    ' Define Agents List ('Agents').
    Set ws = wb.Worksheets("Sheet2")
    Set rng = ws.Cells(ws.Rows.Count, "A").End(xlUp)
    Dim Agents As Variant
    Agents = ws.Range("A2", rng).Value
    
    ' Define DataSet Range ('rng').
    Set rng = wb.Worksheets("Template").Range("A1").CurrentRegion
    
    Application.ScreenUpdating = False
    
    ' Define Delete Range ('rngDel') for Columns.
    Dim rngDel As Range
    Dim cel As Range
    For Each cel In rng.Rows(1).Resize(, rng.Columns.Count - 1) _
                               .Offset(, 1).Cells
        If IsError(Application.Match(cel.Value, Cols, 0)) Then
            collectCells rngDel, cel
        End If
    Next cel
    ' Delete Columns.
    Dim AlreadyDeleted As Boolean
    If Not rngDel Is Nothing Then
        rngDel.EntireColumn.Delete
    Else
        AlreadyDeleted = True
    End If
    
    ' Define Delete Range ('rngDel') for Agents.
    Set rngDel = Nothing
    For Each cel In rng.Columns("A").Resize(rng.Rows.Count - 1) _
                                    .Offset(1).Cells
        If IsError(Application.Match(cel.Value, Agents, 0)) Then
            collectCells rngDel, cel
        End If
    Next cel
    ' Delete Agents (Rows).
    If Not rngDel Is Nothing Then
        rngDel.EntireRow.Delete
        AlreadyDeleted = False
    End If
    
    Application.ScreenUpdating = True

    ' Inform user
    If Not AlreadyDeleted Then
        MsgBox "The data was succesfully deleted.", vbInformation, "Success"
    Else
        MsgBox "The data had already been deleted.", vbExclamation, "No Action"
    End If
    
End Sub

Sub collectCells(ByRef CollectRange As Range, CollectCell As Range)
    If Not CollectCell Is Nothing Then
        If Not CollectRange Is Nothing Then
            Set CollectRange = Union(CollectRange, CollectCell)
        Else
            Set CollectRange = CollectCell
        End If
    End If
End Sub