VBA для удаления столбцов Excel из списка

РЕДАКТИРОВАТЬ2: теперь действительно работает... РЕДАКТИРОВАТЬ: добавлено повторное позиционирование совпадающих столбцов

Использование Match():

Sub DeleteAndSortColumnsByHeader()

    Dim wsData As Worksheet, wsHeaders As Worksheet, mHdr, n As Long
    Dim wb As Workbook, arr, rngTable As Range, addr
    Dim nMoved As Long, nDeleted As Long, nMissing As Long
    
    Set wb = ThisWorkbook 'for example
    Set wsData = wb.Sheets("Products")
    Set wsHeaders = wb.Sheets("Headers")
    
    'get array of required headers
    arr = wsHeaders.Range("A1:A" & _
                   wsHeaders.Cells(Rows.Count, "A").End(xlUp).Row).Value
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    'shift the data over so we can move columns into the required order
    Set rngTable = wsData.Range("a1").CurrentRegion 'original data
    addr = rngTable.Address                         'remember the position
    rngTable.EntireColumn.Insert
    Set rngTable = wsData.Range(addr)               'restore to position before insert
    
    'loop over the headers array
    For n = 1 To UBound(arr, 1)
        mHdr = Application.Match(arr(n, 1), wsData.Rows(1), 0) 'current position of this header
        If IsError(mHdr) Then
            'required header does not exist - do nothing, or add a column with that header?
            wsData.Cells(1, n).Value = arr(n, 1)
            nMissing = nMissing + 1
        Else
            wsData.Columns(mHdr).Cut wsData.Cells(1, n) 'found: move
            nMoved = nMoved + 1
        End If
    Next n
    
    'delete everything not found and moved
    With rngTable.Offset(0, rngTable.Columns.Count)
        nDeleted = Application.CountA(.Rows(1)) 'count remaining headers
        Debug.Print "Clearing: " & .Address
        .EntireColumn.Delete
    End With
    
    Application.Calculation = xlCalculationAutomatic
    Debug.Print "moved", nMoved
    Debug.Print "missing", nMissing
    Debug.Print "deleted", nDeleted
End Sub

В Листе 2 очистите ячейки, в которых отображаются имена столбцов, которые необходимо удалить. И запустите приведенный ниже код.

Sub DeleteColumnByHeader()
    For Col = 1517 To 2 Step -1
        If Range("Sheet2!A" & Col).Value == "" Then
            Columns(Col).EntireColumn.Delete
        End If
    Next
End Sub

Удалить столбцы по заголовкам

• Процедура DeleteColumnsByHeaders выполнит эту работу.
• Настройте значения в разделе констант.
• Оставшиеся две процедуры предназначены для легкого тестирования.

Тестирование

• Чтобы протестировать процедуру, добавьте новую книгу и убедитесь, что она содержит рабочие листы Sheet1 и Sheet2.
• Добавьте модуль и скопируйте в него весь код.
• Запустите процедуры PopulateSourceRowRange и PopulateDestinationColumnRange. Посмотрите на рабочие листы, чтобы увидеть пример настройки.
• Теперь запустите процедуру DeleteColumnsByHeaders. Посмотрите на рабочий лист назначения (Sheet1) и посмотрите, что произошло: все ненужные столбцы были удалены, остались только «сотни».

Option Explicit

Sub DeleteColumnsByHeaders()

    Const sName As String = "Sheet2"
    Const sFirst As String = "A2"
    
    Const dName As String = "Sheet1"
    Const dhRow As String = "A2:BQM2"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Create a reference to the Source Column Range (unwanted headers).
    Dim srg As Range
    Dim srCount As Long
    With wb.Worksheets(sName).Range(sFirst)
        Dim slCell As Range
        Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If slCell Is Nothing Then Exit Sub
        srCount = slCell.Row - .Row + 1
        Set srg = .Resize(srCount)
    End With
    
    ' Write the values from the Source Range to the Source Data Array.
    Dim sData As Variant
    If srCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
    Else
        sData = srg.Value
    End If
    
    ' Create a reference to the Destination Row Range.
    Dim drg As Range: Set drg = wb.Worksheets(dName).Range(dhRow)

    ' Combine all cells containing unwanted headers into the Union Range.
    Dim urg As Range
    Dim dCell As Range
    For Each dCell In drg.Cells
        If IsNumeric(Application.Match(dCell, sData, 0)) Then
            If urg Is Nothing Then
                Set urg = dCell
            Else
                Set urg = Union(urg, dCell)
            End If
        End If
    Next dCell
    
    Application.ScreenUpdating = False
    
    ' Delete the entire columns of the Union Range.
    If Not urg Is Nothing Then
        urg.EntireColumn.Delete
    End If
    
    Application.ScreenUpdating = True
    
End Sub

' Source Worksheet ('Sheet1'):
' Writes the numbers from 1 to 1807 into the cells of the row range
' and to five rows below.
Sub PopulateSourceRowRange()
    With ThisWorkbook.Worksheets("Sheet1").Range("A2:BQM2").Resize(6)
        .Formula = "=COLUMN()"
        .Value = .Value
    End With
End Sub

' Destination Worksheet ('Sheet2'):
' Writes the numbers from 1 to 1807 except the hundreds (100, 200,... 1800)
' to the range 'A2:A1790'. The hundreds are the columns you want to keep.
Sub PopulateDestinationColumnRange()
    Dim n As Long, r As Long
    r = 1
    With ThisWorkbook.Worksheets("Sheet2")
        For n = 1 To 1807
            If n Mod 100 > 0 Then
                r = r + 1
                .Cells(r, "A").Value = n
            End If
        Next n
    End With
End Sub