Excel VBA - 保留指定列并删除所有其他列

Posted 2023-04-17

我经常要从公司的系统里导出一张数据表，n行数据，第一行是表头。而我只需要这张表里的某几列数据。由于系统时常会更新，表格式不固定。所以我需要在一个宏里实现以下两个功能：
1. 在表头里找到指定的列：“品号”、“数量”、“交期”；
2. 保留指定的列，删除其他所有列。

参考技术A Sub Macro1()
Dim a, b
b = 0
a = 1
For a = a To 255 Step 0
If Cells(1, a) = "品号" Or Cells(1, a) = "数量" Or Cells(1, a) = "交期" Then
a = a + 1
Else
Columns(a).Select
Selection.Delete Shift:=xlToLeft
End If
b = b + 1
If b > 255 Then
a = 300
End If
Next a
End Sub追问

我有2点没太明白：
1. b的作用是什么？
2. 为什么是255？
谢谢。

追答

b是计算循环次数，总共查找255列就结束，255是列数，不清楚你数据总共多少列，所以弄个255列，根据你的列数255可以改小点，不需要查找那么多列。

本回答被提问者和网友采纳 参考技术B 不如研究一下EXCEL里的数据导入
表格作好后，以后直接刷新就行了 参考技术C 根据第一行为条件，循环，把不是这三种的删除即可 参考技术D 那你直接删除想删除的列不就可以了吗

使用VBA循环遍历每一列并从大到小排序

【中文标题】使用VBA循环遍历每一列并从大到小排序

【英文标题】：Using VBA to loop through each column and sort from largest to smallest

【发布时间】：2022-01-01 19:14:37

【问题描述】：

我有一个由 excel 中的数字组成的数据集，包含 300 行和 2677 列，我希望遍历每一列并将它们从最大到最小排序。

我尝试修改下面的代码，但找不到循环遍历每一列并按从大到小排序的方法，谁能帮帮我吗？

    Range("I5").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Add2 Key:=Range("I5:I312" _
        ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet3").Sort
        .SetRange Range("I5:I312")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

【参考方案1】：

请尝试下一个代码。无需选择任何东西，选择只会消耗Excel资源，不会带来任何好处：

Sub SortColumns()
 Dim sh As Worksheet, lastCol As Long, i As Long
 Set sh = Worksheets("Sheet3")
 lastCol = 2677 'it can be calculated, if all existing columns should be sorted
 With Application 'a little optimization
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
 End With
 For i = 1 To lastCol
    sh.Range(sh.cells(5, i), sh.cells(5, i).End(xlDown)).Sort key1:=sh.cells(5, i), _
                  order1:=xlDescending, Header:=xlGuess, Orientation:=xlSortColumns
 Next i
 With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
 End With
End Sub

上面的代码假定排序范围内不存在空单元格。如果它们可能存在，则要排序的范围的最后一行应该以不同的方式计算。我保留了你的计算方式，但没有选择......

【参考方案2】：

对列进行降序排序

假设数据从包含此代码 (ThisWorkbook) 的工作簿的 Sheet3 的单元格 I5 开始。

Option Explicit

Sub SortColumnsDescending()
' Needs the 'RefColumn' function.
    Const ProcTitle As String = "Sort Columns Descending"
    
    Const wsName As String = "Sheet3"
    Const FirstCellAddress As String = "I5"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
    Dim lCell As Range
    Set lCell = ws.Cells(fCell.Row, ws.Columns.Count).End(xlToLeft)
    If lCell.Column < fCell.Column Then Exit Sub ' no data in header row range
    
    Dim hrrg As Range: Set hrrg = ws.Range(fCell, lCell) ' Header Row Range
    Dim frrg As Range: Set frrg = hrrg.Offset(1) ' Data First Row Range
    
    Application.ScreenUpdating = False
    
    Dim crg As Range ' Current Column Range
    Dim frCell As Range ' Current First Row Cell
    
    For Each frCell In frrg.Cells
        Set crg = RefColumn(frCell)
        If Not crg Is Nothing Then
            crg.Sort Key1:=crg, Order1:=xlDescending, Header:=xlNo
            Set crg = Nothing
        'Else ' no data in column range
        End If
    Next frCell
    
    Application.ScreenUpdating = True
    
    MsgBox "Columns sorted.", vbInformation, ProcTitle
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With

End Function