Блог

Я новичок в VBA… Я пытаюсь удалить все столбцы из файла Sheet1: «Template» ROW1 / headers, который не соответствует ни одному из значений ячеек в varList:»ColumnsList» (то есть в Sheet3).

Как мне выбрать заголовки или как мне выбрать диапазон строк 1 для поиска?

Кроме того, у меня есть ошибка времени выполнения 5 в этой строке: недопустимый вызов процедуры или аргумент.

Если пересекаются (rng.Ячейки (1, i).Весь столбец, rngF) Тогда ничего

Любая добрая душа, которая поможет мне с этим, пожалуйста?

Кроме того, мне нужно сделать то же самое, но со строками из листа 1: «Шаблон». Мне нужно удалить любую строку, которая не СОДЕРЖИТ значения ячейки из списка переменных: «Агенты» (то есть в 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
  

Удалите столбцы, затем строки

Описание

• Удаляет столбцы, которые в первой строке не содержат значений из списка. Затем удаляет строки, которые в первом столбце не содержат значений из другого списка.

Поток

• Записывает значения из диапазона A2 до последней ячейки в Sheet3 Cols массив.
• Записывает значения из диапазона A2 до последней ячейки в Sheet2 Agents массив.
• Использование CurrentRegion определяет DataSet Range ( rng ) .
• Перебирает ячейки ( cel ) в первой строке, начиная со 2-го столбца, и сравнивает их значения со значениями из Cols массива. Если не найдено, добавляет ячейки в Delete Range ( rngDel ).
• Окончательно удаляет все столбцы «собранных» ячеек.
• Перебирает ячейки ( cel ) в первом столбце, начиная со 2-й строки, и сравнивает их значения со значениями из Agents массива. Если не найдено, добавляет ячейки в 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