Excel VBA实现外部表导入、数据筛选及阈值拆分列代码求助

核心功能修正点 #

• 外部工作簿静默加载：关闭屏幕更新、禁用链接更新提示、只读模式打开外部文件，彻底解决导入过程中外部窗口闪现、弹窗问题
• 工作表位置自动校准：导入的工作表直接放置在「Dashboard」工作表后方，无需硬编码工作表序号
• Total列动态匹配：通过表头检索自动定位「Total」列位置，兼容数据源列顺序调整场景，避免硬编码列号引发的报错
• 筛选逻辑补全：基于动态定位的列号执行筛选，仅保留Total列数值大于1的行
• 数据拆分逻辑实现：在Total列相邻位置插入「p」「b」两列，按规则拆分数据：Total值大于28的内容填入b列，小于等于28的内容填入p列，仅对筛选后的可见行生效
• 状态兜底恢复：无论宏运行是否报错，都会自动恢复Excel的屏幕刷新、事件触发、弹窗提示配置，避免软件状态异常

完整可直接使用的VBA代码 #

Option Explicit

Sub ImportAndProcessDATA()
    Dim wsDATA As Worksheet, wsDash As Worksheet
    Dim fName As Variant, wbSource As Workbook
    Dim colTotal As Range, lastRow As Long
    Dim visRng As Range, c As Range
    
    ' 保存Excel初始配置，运行结束后兜底恢复
    Dim oldScreenUpd As Boolean, oldEnableEvt As Boolean, oldDisplayAlrt As Boolean
    oldScreenUpd = Application.ScreenUpdating
    oldEnableEvt = Application.EnableEvents
    oldDisplayAlrt = Application.DisplayAlerts
    
    On Error GoTo ErrorHandler
    ' 关闭闪屏、事件、弹窗相关配置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ' 删除已存在的DATA工作表
    On Error Resume Next
    Set wsDATA = ThisWorkbook.Sheets("DATA")
    If Not wsDATA Is Nothing Then wsDATA.Delete
    On Error GoTo ErrorHandler
    
    ' 校验Dashboard工作表是否存在
    On Error Resume Next
    Set wsDash = ThisWorkbook.Sheets("Dashboard")
    On Error GoTo ErrorHandler
    If wsDash Is Nothing Then
        MsgBox "当前工作簿未找到「Dashboard」工作表，请检查后重试", vbExclamation
        GoTo Cleanup
    End If
    
    ' 弹出文件选择框
    fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*", Title:="选择待导入数据源")
    If fName = False Then
        MsgBox "未选择数据源，宏退出", vbInformation
        GoTo Cleanup
    End If
    
    ' 静默打开外部工作簿
    Set wbSource = Workbooks.Open( _
        Filename:=fName, _
        UpdateLinks:=0, _
        ReadOnly:=True, _
        AddToMru:=False)
    
    ' 导入首个工作表到Dashboard后方
    wbSource.Sheets(1).Copy After:=wsDash
    wbSource.Close SaveChanges:=False
    Set wbSource = Nothing
    
    ' 重命名导入表为DATA
    Set wsDATA = ThisWorkbook.Sheets(wsDash.Index + 1)
    wsDATA.Name = "DATA"
    
    ' 动态定位Total列
    Set colTotal = wsDATA.Rows(1).Find(What:="Total", LookIn:=xlValues, LookAt:=xlWhole)
    If colTotal Is Nothing Then
        MsgBox "数据源中未找到「Total」列，请检查文件", vbExclamation
        GoTo Cleanup
    End If
    
    ' 执行自动筛选，仅保留Total值>1的行
    wsDATA.AutoFilterMode = False
    lastRow = wsDATA.Cells(wsDATA.Rows.Count, colTotal.Column).End(xlUp).Row
    wsDATA.Range(wsDATA.Cells(1, 1), wsDATA.Cells(lastRow, wsDATA.Columns.Count)).AutoFilter _
        Field:=colTotal.Column, _
        Criteria1:=">1", _
        Operator:=xlAnd
    
    ' 插入p、b两列
    colTotal.Offset(0, 1).Insert Shift:=xlToRight
    colTotal.Offset(0, 1).Insert Shift:=xlToRight
    wsDATA.Cells(1, colTotal.Column + 1).Value = "p"
    wsDATA.Cells(1, colTotal.Column + 2).Value = "b"
    
    ' 按规则拆分可见行数据
    On Error Resume Next
    Set visRng = wsDATA.Range(wsDATA.Cells(2, colTotal.Column), wsDATA.Cells(lastRow, colTotal.Column)).SpecialCells(xlCellTypeVisible)
    On Error GoTo ErrorHandler
    If Not visRng Is Nothing Then
        For Each c In visRng
            If IsNumeric(c.Value) Then
                If c.Value > 28 Then
                    c.Offset(0, 2).Value = c.Value
                Else
                    c.Offset(0, 1).Value = c.Value
                End If
            End If
        Next c
    End If
    
    MsgBox "数据导入处理完成", vbInformation

Cleanup:
    ' 恢复Excel初始配置
    Application.ScreenUpdating = oldScreenUpd
    Application.EnableEvents = oldEnableEvt
    Application.DisplayAlerts = oldDisplayAlrt
    ' 确保外部工作簿正常关闭
    If Not wbSource Is Nothing Then
        wbSource.Close SaveChanges:=False
        Set wbSource = Nothing
    End If
    Exit Sub

ErrorHandler:
    MsgBox "运行出错：" & Err.Description, vbCritical
    Resume Cleanup
End Sub

内容的提问来源于stack exchange，提问作者JTovar