VBA 从列表中删除 Excel 列

Question

我经常下载一个包含 1000 多列的 Excel 文件，其中许多是不需要的，手动删除它们非常繁琐。我找到了一个可以删除不需要的列的 VBA，但这种方法不适合大型列表。

所以，我有一个工作簿，其中 Sheet1 是从 A 到 BQM 的数据和列。我取了所有标题名称并将它们转换为 Sheet2 (A2:A1517) 中的 A 列。我想我正在寻找一种方法让 vba 浏览 Sheet2 中的表格并删除 Sheet1 上任何匹配的标题标题。有什么建议？我是新手，所以慢慢来。

Sub DeleteColumnByHeader()

    Set P = Range("A2:BQM2")

    For Each cell In P

        If cell.Value = "MAP Price" Then cell.EntireColumn.Delete

        If cell.Value = "Retail Price" Then cell.EntireColumn.Delete

        If cell.Value = "Cost" Then cell.EntireColumn.Delete

        If cell.Value = "Additional Specifications" Then cell.EntireColumn.Delete

    Next

End Sub

Answer 1

在 Sheet2 中，请清除显示要删除的列名称的单元格。 并运行以下代码。

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

Answer 2

EDIT2：现在确实有效... 编辑：添加了匹配列的重新定位

使用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

Answer 3

按标题删除列

• 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