从数组中删除不包含值的整列

如何解决从数组中删除不包含值的整列

我需要基于该列中的单元格是否包含某个单元格中的值来删除工作表中的整个列。我在另一个站点上找到了这段代码，由于某种原因我无法链接到该代码。这段代码对我来说是完美的，除非如果单元格包含数组中的值，它将删除所有列。我希望它做相反的事情：如果它不包含数组中的值，则删除该列。基本上是相反的。

代码如下：

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("Departure Time","Trailer Type","From Depot / Store Name ","Trip Position","To Store Number","To Store / Depot Name","Product Code","Pallets") 'I want to keep columns with these values,NOT DELETE THEM

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

        With Sheets("Nastavit D").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)
                    End If
                    Set rngFound = .FindNext(After:=rngFound)
                Loop
            End If
        End With
    Next lngarrCounter

    If Not rngToDelete Is Nothing Then rngToDelete.EntireColumn.Delete

    'Application.ScreenUpdating = True


End Sub

解决方法

请按原样使用您的代码，但请替换：

If Not rngToDelete Is Nothing Then rngToDelete.EntireColumn.Delete

具有：

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

并在同一模块中复制下一个功能：

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

该函数检查与包含数组字符串的列不相交的列，并创建一个范围。这将用于删除整列...