本宏用于：将一份“源数据表”按规则筛选、清洗后，生成结构化的“输出明细表”。
主要动作：
自动识别源表关键列（数值列 / 文本列 / 标记列 / 复制截止列）；
逐行判定：保留有效行、静默过滤空行、对命中标记的行在源表标红；
整块读入内存再批量写回，提升性能；
后处理：加自动筛选、冻结窗格、缩放、统一数字格式与对齐；
将本次复制行数写入明细表指定单元格，并弹出运行报告。
' ============================================================================
' 1. 【核心结构体定义】
' ============================================================================
Public Type ColumnInfo
DecimalStartCol As Long
DecimalEndCol As Long
SpecialTextCol As Long
lastColToCopy As Long
InvalidCol As Long ' 标记判定列(AQ)索引
End Type
' ============================================================================
' 2. 【精简高效配置区域】 ← 所有“用户可能修改的参数”集中在此，逻辑代码无需改动
' 使用约定：只改本区域的值即可；所有项均为编译期常量，WPS 导入即生效。
' ============================================================================
' ---- 工作表与行列位置 ----
Public Const SOURCE_SHEET_NAME As String = "源数据表" ' 数据源工作表名（读取方）；若监控表改名需同步修改此处
Public Const TARGET_SHEET_NAME As String = "输出明细表" ' 输出工作表名（每次运行先删后建，确保结果干净）
Public Const DATA_START_ROW As Long = 7 ' 数据起始行：表头占 1~6 行，第 7 行起为正式数据
Public Const HEADER_START_ROW As Long = 1 ' 表头起始行
Public Const HEADER_END_ROW As Long = 6 ' 表头结束行；同时也是 FREEZE_ROWS 的默认值来源（见下方）
' ---- 列识别关键词（按表头文字“全词精准匹配”，匹配前会先去掉空格/换行/非断空格并转大写）----
Public Const EXCLUDE_COL_HEADER As String = "截止列标识" ' 命中该表头后，该列及其右侧所有列都不复制到明细表（作为复制右边界）
' 注意：DECIMAL_COL_HEADERS 按历史约定(#3)保持原样未改；多个列名用半角逗号分隔
Public Const DECIMAL_COL_HEADERS As String = "数值字段1,数值字段2,数值字段3,数值字段4,数值字段5,数值字段6,数值字段7,数值字段8,数值字段9,数值字段10,数值字段11,数值字段12,数值字段13,数值字段14,数值字段15,数值字段16,数值字段17,数值字段18,数值字段19"
Public Const SPECIAL_TEXT_HEADER As String = "文本标识" ' 文本列：整列强制文本格式(@)，防止编码/前导零被 Excel 自动转换；多列用逗号分隔
Public Const INVALID_COL_HEADER As String = "标记判定" ' “哪一列”负责标红判定（当前=AQ 列）；VBA 只读取它，判定逻辑在工作表里
Public Const INVALID_MARK_TEXT As String = "剔除" ' “什么值”算无效：AQ 列文字命中本值即标红（与“哪一列”是两个独立维度，勿混淆）
' ---- 末行探测列 ----
Public Const INDEX_COL_LETTER As String = "AR" ' 用该列（同标识索引列）定位真实末行；避免 A 列中部空行导致末行被提前截断
' 若该列整列为空，则退化为全表 Find（见 ProcessProductionData 第 89~92 行）
' ---- 外观与格式 ----
Public Const SHEET_ZOOM_PERCENT As Long = 90 ' 明细表显示缩放比例(%)
Public Const SHEET_TAB_COLOR As Long = 255 ' 明细表标签颜色（VBA 色值，255=红色）
Public Const MARK_COLOR As Long = &HCCCCFF ' 标红底色 = RGB(255,204,204) 浅红（&HCCCCFF 即数值 13421823，用十六进制便于阅读）
Public Const DECIMAL_NUMBER_FORMAT As String = "#,##0.00_);(#,##0.00)" ' 小数列数字格式：千分位+两位小数，负数用括号显示
Public Const TEXT_NUMBER_FORMAT As String = "@" ' 文本列数字格式：强制按文本存储
' ---- 行为开关（改 True/False 即可切换）----
Public Const BLANK_ZERO_DECIMALS As Boolean = True ' 小数列“真零”是否显示为空：True=隐藏零值(更干净)，False=保留 0
Public Const ENABLE_PERFORMANCE_MODE As Boolean = True ' 是否开启加速四件套(ScreenUpdating/Calculation/EnableEvents/DisplayAlerts)；调试想看中间过程设 False
Public Const ENABLE_HEADER_FILTER As Boolean = True ' 是否给表头行加自动筛选下拉（明细表常用，不需要可关）
' ---- 冻结窗格 ----
Public Const ENABLE_FREEZE_PANES As Boolean = True ' 是否冻结窗格
Public Const FREEZE_ROWS As Long = HEADER_END_ROW ' 冻结“前几行”（默认=表头 6 行；与表头行解耦，可单独设如 4）
Public Const FREEZE_COLS As Long = 10 ' 冻结“前几列”（默认 0=不冻结列；设 2 可固定左侧两列标识列）。注意须 ≥ 0（内部已做防御）
' ============================================================================
' 3. 【主处理程序 ProcessProductionData】 入口：在 WPS 中运行本宏即可
' 整体流程：
' 定位源表 → 开启性能模式 → 删除旧明细表并新建 → 探测真实末行并清洗底色 →
' 识别关键列(AutoDetectColumnsScheme2) → 复制表头 → 内存批处理数据行(ProcessDataRowsArray) →
' 后处理美化(筛选/冻结/缩放/格式, ApplyFormatting) → 恢复环境 → 弹出运行报告。
' 安全：全程挂全局错误守护(ErrHandler)，任何中途报错都能恢复 Application 环境，避免 WPS 卡死。
' ============================================================================
Public Sub ProcessProductionData()
Dim startTime As Double: startTime = Timer
Dim ws As Worksheet, destSheet As Worksheet
Dim colInfo As ColumnInfo
Dim lastRow As Long, destRow As Long, copyCount As Long, redCount As Long, totalRows As Long
On Error Resume Next
Set ws = ThisWorkbook.Sheets(SOURCE_SHEET_NAME)
On Error GoTo 0
If ws Is Nothing Then MsgBox "未找到源工作表！", vbExclamation: Exit Sub
' 开启低性能环境极致加速防线（受 ENABLE_PERFORMANCE_MODE 控制）
If ENABLE_PERFORMANCE_MODE Then
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.DisplayAlerts = False
End With
End If
On Error GoTo ErrHandler ' #4 全局错误守护：中途报错也能恢复环境，避免 Excel 卡死
' 冲突删除原有的明细表
On Error Resume Next
ThisWorkbook.Sheets(TARGET_SHEET_NAME).Delete
On Error GoTo 0
On Error GoTo ErrHandler ' #4 重新挂回全局守护
' 新建目标表
Set destSheet = ThisWorkbook.Sheets.Add(Before:=ws)
destSheet.Name = TARGET_SHEET_NAME
destSheet.Tab.Color = SHEET_TAB_COLOR
' 获取边界并清洗底色（#5 固定到 INDEX_COL_LETTER[同文本标识索引]列取真实末行，避免 A 列中部空行截断）
Dim lastCell As Range
Set lastCell = ws.Columns(INDEX_COL_LETTER).Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If lastCell Is Nothing Then
Set lastCell = ws.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
End If
If lastCell Is Nothing Then lastRow = 0 Else lastRow = lastCell.Row
If lastRow >= DATA_START_ROW Then
ws.Range(ws.Rows(DATA_START_ROW), ws.Rows(lastRow)).Interior.ColorIndex = xlNone
totalRows = lastRow - DATA_START_ROW + 1
Else
totalRows = 0
End If
colInfo = AutoDetectColumnsScheme2(ws)
' 复制表头（#6 用值+数字格式，避免把监控表公式带进明细表；再补格式保留表头外观）
If colInfo.lastColToCopy > 0 Then
ws.Range(ws.Cells(HEADER_START_ROW, 1), ws.Cells(HEADER_END_ROW, colInfo.lastColToCopy)).Copy
destSheet.Range(destSheet.Cells(HEADER_START_ROW, 1), destSheet.Cells(HEADER_END_ROW, colInfo.lastColToCopy)).PasteSpecial xlPasteValuesAndNumberFormats
destSheet.Range(destSheet.Cells(HEADER_START_ROW, 1), destSheet.Cells(HEADER_END_ROW, colInfo.lastColToCopy)).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End If
destRow = DATA_START_ROW
ProcessDataRowsArray ws, destSheet, destRow, copyCount, redCount, colInfo, lastRow
' 将本次成功复制的行数写入明细表 A5 单元格（放在表头复制之后，避免被 PasteSpecial 覆盖）
destSheet.Cells(5, 1).Value = copyCount
' 后处理美化：无条件调用（空表仅保留筛选/冻结/缩放；有数据再铺格式，详见 ApplyFormatting 内部空表保护）
ApplyFormatting ws, destSheet, destRow, colInfo
' 环境恢复（受 ENABLE_PERFORMANCE_MODE 控制）
If ENABLE_PERFORMANCE_MODE Then
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.DisplayAlerts = True
End With
End If
If Not destSheet Is Nothing Then destSheet.Activate
MsgBox "处理完成！" & vbCrLf & _
"----------------------------------" & vbCrLf & _
"本次运行耗时：" & Format(Timer - startTime, "0.00") & " 秒" & vbCrLf & _
"源表数据总计：" & totalRows & " 行" & vbCrLf & _
"----------------------------------" & vbCrLf & _
"成功复制行数：" & copyCount & " 行" & vbCrLf & _
"过滤标红行数：" & redCount & " 行", vbInformation, "运行报告 by:蛋蛋之家"
Exit Sub
ErrHandler:
If ENABLE_PERFORMANCE_MODE Then
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.DisplayAlerts = True
End With
End If
Application.CutCopyMode = False
MsgBox "运行出错（已自动恢复环境）：" & Err.Description, vbCritical, "错误 by:***"
End Sub
' ============================================================================
' 4. 【表头比对函数：扫描表头行(第6行)，识别各类关键列的位置】
' 算法：遍历表头每个单元格 → 清洗(去空格/换行/非断空格并转大写) → 与各关键词数组做“全词匹配”。
' 产出 ColumnInfo：小数列起止(DecimalStart/EndCol)、文本列(SpecialTextCol)、
' 复制截止列(lastColToCopy)、标记判定列(InvalidCol)。
' 语义说明：EXCLUDE 决定“复制右边界”；DECIMAL 决定数字格式区间；
' SPECIAL 决定文本格式列；INVALID 决定标红判定列(仅读取，不参与格式)。
' 多个关键词用逗号分隔，匹配时同样会做清洗，故表头带空格也能命中。
' ============================================================================
Public Function AutoDetectColumnsScheme2(ws As Worksheet) As ColumnInfo
Dim info As ColumnInfo
Dim lastCol As Long, i As Long, j As Long
Dim cleanText As String
Dim excludeArr() As String: excludeArr = Split(EXCLUDE_COL_HEADER, ",")
Dim decimalArr() As String: decimalArr = Split(DECIMAL_COL_HEADERS, ",")
Dim specialArr() As String: specialArr = Split(SPECIAL_TEXT_HEADER, ",")
Dim invalidArr() As String: invalidArr = Split(INVALID_COL_HEADER, ",")
Dim excludeStartCol As Long
lastCol = ws.Cells(HEADER_END_ROW, ws.Columns.Count).End(xlToLeft).Column
excludeStartCol = lastCol + 1
info.DecimalStartCol = lastCol + 1
info.DecimalEndCol = 0
info.InvalidCol = 0
For i = 1 To lastCol
cleanText = ws.Cells(HEADER_END_ROW, i).Value
cleanText = Replace(Replace(Replace(Replace(cleanText, " ", ""), vbCr, ""), vbLf, ""), Chr(160), "")
cleanText = UCase(Trim(cleanText))
If cleanText <> "" Then
For j = LBound(excludeArr) To UBound(excludeArr)
If cleanText = UCase(Trim(Replace(excludeArr(j), " ", ""))) Then
excludeStartCol = IIf(i < excludeStartCol, i, excludeStartCol)
End If
Next j
For j = LBound(specialArr) To UBound(specialArr)
If cleanText = UCase(Trim(Replace(specialArr(j), " ", ""))) Then info.SpecialTextCol = i
Next j
For j = LBound(invalidArr) To UBound(invalidArr)
If cleanText = UCase(Trim(Replace(invalidArr(j), " ", ""))) Then info.InvalidCol = i
Next j
For j = LBound(decimalArr) To UBound(decimalArr)
If cleanText = UCase(Trim(Replace(decimalArr(j), " ", ""))) Then
info.DecimalStartCol = IIf(i < info.DecimalStartCol, i, info.DecimalStartCol)
info.DecimalEndCol = IIf(i > info.DecimalEndCol, i, info.DecimalEndCol)
End If
Next j
End If
Next i
info.lastColToCopy = IIf(excludeStartCol - 1 < 1, lastCol, excludeStartCol - 1)
If info.DecimalStartCol > info.lastColToCopy Then info.DecimalStartCol = 1
If info.DecimalEndCol = 0 Or info.DecimalEndCol > info.lastColToCopy Then info.DecimalEndCol = info.lastColToCopy
AutoDetectColumnsScheme2 = info
End Function
' ============================================================================
' 5. 【内存数据交互：源表读入数组 → 逐行判定 → 批量写回目标表】
' 设计：整块读入内存数组再写回，避免逐单元格读写；配合性能模式可大幅提速。
' 判定三态 act： 1=复制 0=静默过滤(标记判定列 AQ 为空) -1=标红过滤(命中 INVALID_MARK_TEXT)
' 注意：标红行只在“源表”上色(由主流程收集 redRange 批量上色)，目标表不含标红行。
' ============================================================================
Public Sub ProcessDataRowsArray(srcWs As Worksheet, destWs As Worksheet, ByRef destRow As Long, ByRef copyCount As Long, ByRef redCount As Long, colInfo As ColumnInfo, lastRow As Long)
If lastRow < DATA_START_ROW Or colInfo.lastColToCopy < 1 Then Exit Sub
Dim srcData As Variant
Dim readCol As Long
readCol = colInfo.lastColToCopy
If colInfo.InvalidCol > readCol Then readCol = colInfo.InvalidCol ' 读取范围至少覆盖 AQ 列，便于判定
srcData = srcWs.Range(srcWs.Cells(1, 1), srcWs.Cells(lastRow, readCol)).Value
If Not IsArray(srcData) Then
Dim tempArr As Variant: ReDim tempArr(1 To lastRow, 1 To readCol)
tempArr(lastRow, readCol) = srcData: srcData = tempArr
End If
Dim destData As Variant: ReDim destData(1 To UBound(srcData, 1), 1 To colInfo.lastColToCopy)
Dim i As Long, j As Long
Dim redRange As Range
For i = DATA_START_ROW To lastRow
Dim act As Long ' 1=复制 0=静默过滤(空行/无索引) -1=标红过滤(AQ=无效)
act = DecideRow(srcData, i, colInfo)
If act = 1 Then
copyCount = copyCount + 1
For j = 1 To colInfo.lastColToCopy
If j = colInfo.SpecialTextCol Then
' #2 用数组值的 CStr，去掉慢且受显示格式影响的 .Text
Dim specVal As Variant: specVal = srcData(i, j)
If IsError(specVal) Then
destData(copyCount, j) = ""
Else
destData(copyCount, j) = CStr(specVal)
End If
Else
Dim tempVal As Variant: tempVal = srcData(i, j)
If IsError(tempVal) Then
destData(copyCount, j) = ""
ElseIf j >= colInfo.DecimalStartCol And j <= colInfo.DecimalEndCol And IsNumeric(tempVal) And Val(tempVal) = 0 Then
If BLANK_ZERO_DECIMALS Then destData(copyCount, j) = "" Else destData(copyCount, j) = tempVal
Else
destData(copyCount, j) = tempVal
End If
End If
Next j
ElseIf act = -1 Then
' 标红：AQ=无效，收集到 redRange 循环后批量上色（避免逐行写表，提速）
If redRange Is Nothing Then Set redRange = srcWs.Rows(i) Else Set redRange = Union(redRange, srcWs.Rows(i))
redCount = redCount + 1
Else
' act = 0：标记判定列(AQ)为空 → 静默过滤，不复制也不标红
End If
Next i
' 批量标红（非核心操作，失败也不影响复制结果）
If Not redRange Is Nothing Then
On Error Resume Next
redRange.Interior.Color = MARK_COLOR
On Error GoTo 0
End If
If copyCount > 0 Then
If colInfo.SpecialTextCol > 0 And colInfo.SpecialTextCol <= colInfo.lastColToCopy Then destWs.Columns(colInfo.SpecialTextCol).NumberFormat = TEXT_NUMBER_FORMAT
destWs.Cells(DATA_START_ROW, 1).Resize(copyCount, colInfo.lastColToCopy).Value = destData
destRow = DATA_START_ROW + copyCount
End If
End Sub
' ============================================================================
' 6. 【行判定：真正的判定由工作表 AQ 列(标记判定) 完成，VBA 只负责读取结果】
' 返回三态： 1=复制 0=静默过滤(标记判定列为空) -1=标红过滤(命中 INVALID_MARK_TEXT)
' 设计要点：除“明确命中无效文字”外，其余情况(含公式错误/读取异常/空值)一律“保守复制”，
' 绝不让任何数据被静默删除；空值仅走静默过滤(不复制也不标红)。
' ============================================================================
Public Function DecideRow(srcData As Variant, rowNum As Long, colInfo As ColumnInfo) As Long
Dim v As Variant
If colInfo.InvalidCol > 0 Then
' 仅把“数组读取”这一句包在错误屏蔽里，避免把后续逻辑的错误也吞掉（曾整段屏蔽，有数据丢失风险）
On Error Resume Next
v = srcData(rowNum, colInfo.InvalidCol)
If Err.Number <> 0 Then On Error GoTo 0: DecideRow = 1: Exit Function ' 读取异常→保守复制，防数据静默丢失
On Error GoTo 0
If IsError(v) Then
DecideRow = 1 ' 该单元格是公式错误(#N/A 等)：保守复制，避免误杀
ElseIf UCase(Trim(CStr(v))) = UCase(Trim(INVALID_MARK_TEXT)) Then
DecideRow = -1 ' 命中“无效”文字 → 标红（由主流程批量上色）
ElseIf Trim(CStr(v)) = "" Then
DecideRow = 0 ' 标记判定列(AQ)为空 → 静默过滤，不复制也不标红
Else
DecideRow = 1 ' 其它内容 → 有效，复制
End If
Else
' 标记判定列缺失：无法判定，保守复制所有行（避免误删数据）
DecideRow = 1
End If
End Function
' ============================================================================
' 7. 【后处理格式美化】 #8 用显式窗口对象替代脆弱的 ActiveWindow
' ============================================================================
Public Sub ApplyFormatting(srcWs As Worksheet, destWs As Worksheet, destRow As Long, colInfo As ColumnInfo)
' 后处理：给明细表加筛选/冻结/缩放，并把表头外观铺到数据区、统一对齐与数字格式。
' 本过程“无条件”被主程序调用（即使一行数据都没复制），因此内部对依赖数据区的步骤做了空表保护。
' ① 表头自动筛选（受 ENABLE_HEADER_FILTER 控制；明细表每次重建，不会叠加旧筛选）
If ENABLE_HEADER_FILTER Then destWs.Rows(HEADER_END_ROW).AutoFilter
destWs.Activate ' 冻结依赖 ActiveWindow，必须先激活目标表
' ② 窗口缩放 + 冻结（这两步不依赖是否有数据行，空表也生效）
Dim wnd As Window
Set wnd = ActiveWindow
If Not wnd Is Nothing Then
wnd.Zoom = SHEET_ZOOM_PERCENT
If ENABLE_FREEZE_PANES Then
' FreezePanes 冻结的是“当前选中单元格的左上角”，所以：
' 选中 (FREEZE_ROWS+1 行, FREEZE_COLS+1 列) → 冻结其“前 R 行 + 前 C 列”。
' 用 Max(1,...) 兜底，防止 FREEZE_ROWS/FREEZE_COLS 被误设为负导致 Cells 索引非法而报错。
Dim fr As Long: fr = Application.WorksheetFunction.Max(1, FREEZE_ROWS + 1)
Dim fc As Long: fc = Application.WorksheetFunction.Max(1, FREEZE_COLS + 1)
destWs.Cells(fr, fc).Select
wnd.FreezePanes = True
End If
End If
' ③ 以下操作都依赖“存在数据行”（目标区从 DATA_START_ROW 到 destRow-1）。
' 若一行都没复制（destRow 仍 = DATA_START_ROW），则 destRow-1 < DATA_START_ROW，
' 数据区为空，下面三小步安全跳过，仅保留上面的筛选/冻结/缩放。
If destRow - 1 >= DATA_START_ROW Then
' ③a) 把源表表头行(第6行)的格式铺到明细表数据区，使数据行拥有与表头一致的外观(底色/边框等)
srcWs.Range(srcWs.Cells(HEADER_END_ROW, 1), srcWs.Cells(HEADER_END_ROW, colInfo.lastColToCopy)).Copy
destWs.Range(destWs.Cells(DATA_START_ROW, 1), destWs.Cells(destRow - 1, colInfo.lastColToCopy)).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
' ③b) 数据区统一对齐/换行/取消加粗（覆盖 ③a 带入的表头对齐偏好，确保数据区观感统一）
' 注意：不加粗是显式设定，仅作用于数据区，表头本身的加粗不受影响。
With destWs.Range(destWs.Cells(DATA_START_ROW, 1), destWs.Cells(destRow - 1, colInfo.lastColToCopy))
.WrapText = False
.Rows.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = False
End With
' ③c) 小数列套用数字格式（文本列已在 ProcessDataRowsArray 中单独设为 @，此处不会与之冲突）
If colInfo.DecimalStartCol <= colInfo.DecimalEndCol And colInfo.DecimalStartCol > 0 Then
destWs.Range(destWs.Cells(DATA_START_ROW, colInfo.DecimalStartCol), _
destWs.Cells(destRow - 1, colInfo.DecimalEndCol)).NumberFormat = DECIMAL_NUMBER_FORMAT
End If
End If
End Sub如果觉得文章对你有用，请随意赞赏
数据表 → 明细表 自动筛选生成宏
https://wuqishi.com/archives/detail-sheet-generator
评论