Excel工程量清单VBA一键净化处理教程

Sub CleanBOQ_v3()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim cellText As String
    Dim delRows As Range, delCols As Range
    Dim firstHeaderRow As Long

    ' 关闭屏幕更新和自动计算，提升宏运行效率
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    ' 1. 取消所有合并单元格
    ws.Cells.UnMerge

    ' 获取当前实际使用的行列范围
    lastRow = ws.UsedRange.Rows.Count + ws.UsedRange.Row - 1
    lastCol = ws.UsedRange.Columns.Count + ws.UsedRange.Column - 1

    ' 2. 精准定位唯一的“主表头”行
    firstHeaderRow = 0
    For i = 1 To 20
        For j = 1 To lastCol
            cellText = Replace(Replace(ws.Cells(i, j).Text, " ", ""), " ", "")
            If InStr(cellText, "序号") > 0 Then
                firstHeaderRow = i
                Exit For
            End If
        Next j
        If firstHeaderRow > 0 Then Exit For
    Next i
    If firstHeaderRow = 0 Then firstHeaderRow = 1

    ' 3. 【核心升级：白名单过滤模式】
    ' 只保留我们需要的列，其他任何列（哪怕是导出软件留下的顽固假空列）一律标记删除
    Dim isKeepCol As Boolean
    For j = 1 To lastCol
        isKeepCol = False
        ' 只在表头所在及下方2行内扫描，避免误判数据行
        For i = firstHeaderRow To firstHeaderRow + 2
            cellText = Replace(Replace(ws.Cells(i, j).Text, " ", ""), " ", "")
            ' 白名单：只认这几个核心词汇
            If InStr(cellText, "序号") > 0 Or _
               InStr(cellText, "项目名称") > 0 Or _
               InStr(cellText, "特征") > 0 Or _
               InStr(cellText, "单位") > 0 Or _
               InStr(cellText, "工程量") > 0 Then
                isKeepCol = True
                Exit For
            End If
        Next i

        ' 如果不在白名单中，加入删除队列
        If Not isKeepCol Then
            If delCols Is Nothing Then
                Set delCols = ws.Columns(j)
            Else
                Set delCols = Union(delCols, ws.Columns(j))
            End If
        End If
    Next j

    ' 4. 标记需要剔除的行（特定文本行 + 纯空行）
    For i = 1 To lastRow
        Dim rowShouldDelete As Boolean
        rowShouldDelete = False
        Dim isEmptyRow As Boolean
        isEmptyRow = True

        ' 更严格的空行检测（剔除不可见空格造成的假象）
        For j = 1 To lastCol
            If Len(Trim(Replace(ws.Cells(i, j).Text, Chr(160), ""))) > 0 Then
                isEmptyRow = False
                Exit For
            End If
        Next j
        
        If isEmptyRow Then
            rowShouldDelete = True
        Else
            ' 如果不是空行，遍历单元格匹配特定关键字
            For j = 1 To lastCol
                cellText = Replace(Replace(ws.Cells(i, j).Text, " ", ""), " ", "")

                ' 匹配需要剥离的行
                If InStr(cellText, "分部分项工程项目清单计价表") > 0 Or _
                   InStr(cellText, "工程名称") > 0 Or _
                   InStr(cellText, "材料暂估价") > 0 Or _
                   InStr(cellText, "其中") > 0 Or _
                   InStr(cellText, "分部小计") > 0 Or _
                   InStr(cellText, "本页小计") > 0 Or _
                   InStr(cellText, "合计") > 0 Then
                    rowShouldDelete = True
                    Exit For
                End If

                ' 清除重复的主表头
                If (InStr(cellText, "序号") > 0 Or InStr(cellText, "项目名称") > 0) And i > firstHeaderRow Then
                    rowShouldDelete = True
                    Exit For
                End If

                ' 清除主表头以上的页码等杂乱信息
                If i < firstHeaderRow And (InStr(cellText, "页") > 0 Or InStr(cellText, "第") > 0) Then
                    rowShouldDelete = True
                    Exit For
                End If
            Next j
        End If

        If rowShouldDelete Then
            If delRows Is Nothing Then
                Set delRows = ws.Rows(i)
            Else
                Set delRows = Union(delRows, ws.Rows(i))
            End If
        End If
    Next i

    ' 5. 执行一次性集中删除
    If Not delCols Is Nothing Then delCols.Delete
    If Not delRows Is Nothing Then delRows.Delete

    ' 6. 重新自动调整剩余核心列的列宽
    ws.Cells.EntireColumn.AutoFit
    
    ' 恢复环境设置
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    MsgBox "终极净化完成！白名单模式已生效，所有多余空列已彻底抹除。", vbInformation
End Sub