diff --git a/VBA/Modules/M01_Main.bas b/VBA/Modules/M01_Main.bas index dcb4f0d..dd17806 100644 --- a/VBA/Modules/M01_Main.bas +++ b/VBA/Modules/M01_Main.bas @@ -114,6 +114,13 @@ Public Sub RunBOMConversion() MsgBox "转换完成,但发现部分数据存在逻辑冲突,已生成错误报告。", vbExclamation End If + ' 7. 询问是否生成预处理报表(可选) + If MsgBox("是否生成预处理条件转换对比报表?" & vbCrLf & _ + "(仅展示'接头'类别的条件转换结果)", _ + vbQuestion + vbYesNo, "预处理报表") = vbYes Then + Call GeneratePreprocessingReport + End If + ExitHandler: ' 清理状态 Application.StatusBar = False @@ -124,4 +131,533 @@ ExitHandler: MainErrorHandler: MsgBox "发生运行时错误: " & Err.Description, vbCritical Resume ExitHandler -End Sub \ No newline at end of file +End Sub + +' ============================================================================== +' 过程: GeneratePreprocessingReport +' 职责: 生成预处理条件转换对比报表,展示"接头"类别的条件转换结果 +' ============================================================================== +Public Sub GeneratePreprocessingReport() + On Error GoTo ReportErrorHandler + + Application.StatusBar = "正在生成预处理报表..." + + ' 1. 创建错误日志记录器 + Dim logger As New clsErrorLogger + + ' 2. 验证工作表存在 + If Not WorksheetExists("平台配置清单") Then + MsgBox "未找到[平台配置清单]工作表!", vbCritical + GoTo ReportExitHandler + End If + + Dim wsSrc As Worksheet + Set wsSrc = ActiveWorkbook.Sheets("平台配置清单") + + ' 3. 读取源数据 + Dim arrData As Variant + arrData = M02_DataIO.ReadSourceData(wsSrc) + + If IsEmpty(arrData) Then + MsgBox "没有找到数据!", vbExclamation + GoTo ReportExitHandler + End If + + ' 4. 初始化预处理器(如果"对照表"存在) + If WorksheetExists("对照表") Then + Dim wsMapping As Worksheet + Set wsMapping = ActiveWorkbook.Sheets("对照表") + M05_PreProcessor.InitPreProcessor logger, wsMapping + End If + + ' 5. 处理数据并收集统计信息 + Dim results As Collection + Set results = New Collection + + Dim stats As Object + Set stats = CreateObject("Scripting.Dictionary") + stats("totalRows") = 0 + stats("processedRows") = 0 + stats("successCount") = 0 + stats("warningCount") = 0 + stats("emptyCount") = 0 + stats("orMergeCount") = 0 + + ' 遍历数据 + Dim i As Long + For i = LBound(arrData, 1) To UBound(arrData, 1) + Dim rowIdx As Long + rowIdx = i + M04_Config.SRC_START_ROW ' 原始表行号 + + Dim strCat As String + strCat = CStr(arrData(i, M04_Config.COL_IDX_CAT)) + + ' 只处理"接头"类别 + If strCat = "接头" Then + stats("processedRows") = stats("processedRows") + 1 + + ' 提取数据 + Dim strCode As String, strName As String + Dim strQty As String, strOrigCond As String + + strCode = CStr(arrData(i, M04_Config.COL_IDX_CODE)) + strName = CStr(arrData(i, M04_Config.COL_IDX_NAME)) + strQty = CStr(arrData(i, M04_Config.COL_IDX_QTY)) + strOrigCond = CStr(arrData(i, M04_Config.COL_IDX_COND)) + + ' 调用预处理器 + Dim strConvCond As String + strConvCond = M05_PreProcessor.PreprocessCondition(strOrigCond, strCat, rowIdx) + + ' 分析转换 + Dim strDetails As String + Dim strStatus As String + Dim nORMerges As Long + Dim strMappingDetails As String + + strDetails = AnalyzeConversion(strOrigCond, strConvCond, nORMerges) + strStatus = DetermineStatus(strOrigCond, strConvCond, strCat) + strMappingDetails = ExtractMappingDetails(strOrigCond, strConvCond) + + ' 更新统计 + If strStatus = "成功" Then stats("successCount") = stats("successCount") + 1 + If strStatus = "警告" Then stats("warningCount") = stats("warningCount") + 1 + If strStatus = "空条件" Then stats("emptyCount") = stats("emptyCount") + 1 + stats("orMergeCount") = stats("orMergeCount") + nORMerges + + ' 添加到结果集合(11列:行号, 代号, 名称, 数量, 类别, 原始条件, 转换后条件, 映射详情, 转换说明, 状态, 错误/警告) + results.Add Array(rowIdx, strCode, strName, strQty, strCat, _ + strOrigCond, strConvCond, strMappingDetails, strDetails, strStatus, "") + End If + Next i + + ' 6. 创建或清除工作表 + Dim wsReport As Worksheet + On Error Resume Next + Set wsReport = ActiveWorkbook.Sheets("条件转换对比表") + On Error GoTo ReportErrorHandler + + If wsReport Is Nothing Then + Set wsReport = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.count)) + wsReport.Name = "条件转换对比表" + Else + wsReport.Cells.Clear + End If + + ' 7. 写入统计信息(第1-6行) + wsReport.Cells(1, 1).Value = "总处理行数: " & stats("processedRows") + wsReport.Cells(2, 1).Value = "转换成功数: " & stats("successCount") + wsReport.Cells(3, 1).Value = "警告数: " & stats("warningCount") + wsReport.Cells(4, 1).Value = "空条件行数: " & stats("emptyCount") + wsReport.Cells(5, 1).Value = "OR条件合并次数: " & stats("orMergeCount") + + ' 8. 写入表头(第8行) + Dim headers As Variant + headers = Array("行号", "代号", "名称", "数量", "类别", _ + "原始条件", "转换后条件", "映射详情", "转换说明", "状态", "错误/警告") + + Dim col As Long + For col = 1 To 11 + wsReport.Cells(8, col).Value = headers(col - 1) + Next col + + ' 9. 批量写入数据(从第9行开始) + If results.count > 0 Then + Dim arrOutput() As Variant + ReDim arrOutput(1 To results.count, 1 To 11) + + Dim j As Long + j = 1 + Dim result As Variant + For Each result In results + Dim k As Long + For k = 1 To 11 + arrOutput(j, k) = result(k - 1) + Next k + j = j + 1 + Next result + + wsReport.Range("A9").Resize(results.count, 11).Value = arrOutput + End If + + ' 10. 格式化工作表 + Call FormatReportWorksheet(wsReport, results.count) + + Application.StatusBar = False + MsgBox "预处理报表生成完成!", vbInformation + Exit Sub + +ReportErrorHandler: + Application.StatusBar = False + MsgBox "生成报表时出错:" & vbCrLf & _ + "错误 " & Err.Number & ": " & Err.Description, _ + vbCritical, "报表生成错误" + +ReportExitHandler: + Application.StatusBar = False +End Sub + +' ============================================================================== +' 辅助函数: FormatReportWorksheet +' 职责: 格式化报表工作表 +' ============================================================================== +Private Sub FormatReportWorksheet(ByVal wsReport As Worksheet, ByVal rowCount As Long) + ' 1. 格式化统计区域 + With wsReport.Range("A1:A6") + .Font.Bold = True + .Font.Size = 11 + .Interior.Color = RGB(200, 220, 255) + End With + + ' 2. 格式化表头 + With wsReport.Range("A8:K8") + .Font.Bold = True + .Interior.Color = RGB(217, 217, 217) + .HorizontalAlignment = xlCenter + End With + + ' 3. 格式化状态列和映射详情列(根据值着色) + Dim lastRow As Long + lastRow = 8 + rowCount + + If rowCount > 0 Then + Dim r As Long + For r = 9 To lastRow + ' 映射详情列(第8列,H列)- 有映射时使用浅绿色背景 + If Len(wsReport.Cells(r, 8).Value) > 0 Then + wsReport.Cells(r, 8).Interior.Color = RGB(230, 255, 230) + wsReport.Cells(r, 8).Font.Color = RGB(0, 100, 0) + wsReport.Cells(r, 8).Font.Italic = True + End If + + ' 状态列(第10列,J列) + Select Case wsReport.Cells(r, 10).Value + Case "成功" + wsReport.Cells(r, 10).Interior.Color = RGB(200, 255, 200) + Case "警告" + wsReport.Cells(r, 10).Interior.Color = RGB(255, 255, 200) + Case "未转换" + wsReport.Cells(r, 10).Interior.Color = RGB(240, 240, 240) + Case "空条件" + wsReport.Cells(r, 10).Interior.Color = RGB(220, 240, 255) + End Select + Next r + + ' 4. 应用边框 + With wsReport.Range("A8:K" & lastRow) + .Borders.LineStyle = xlContinuous + .Borders.Weight = xlThin + End With + End If + + ' 5. 自动调整列宽 + wsReport.Columns.AutoFit + + ' 6. 设置文本换行 + wsReport.Columns("F:K").WrapText = True + + ' 7. 冻结窗格 + wsReport.Activate + ActiveWindow.FreezePanes = False + wsReport.Rows(9).Select + ActiveWindow.FreezePanes = True + + ' 8. 选中和取消选中,避免选区 + wsReport.Cells(1, 1).Select +End Sub + +' ============================================================================== +' 辅助函数: AnalyzeConversion +' 职责: 分析转换内容,返回说明字符串 +' ============================================================================== +Private Function AnalyzeConversion( _ + ByVal strOrig As String, _ + ByVal strConv As String, _ + ByRef outORMerges As Long _ +) As String + Dim details As Collection + Set details = New Collection + + ' 计算OR合并次数 + Dim origORCount As Long, convORCount As Long + origORCount = CountOccurrences(strOrig, " OR ") + convORCount = CountOccurrences(strConv, " OR ") + outORMerges = origORCount - convORCount + If outORMerges > 0 Then details.Add "OR合并:" & outORMerges & "次" + + ' 检测azxs映射 + If ContainsAzxsChange(strOrig, strConv) Then + details.Add "azxs值映射" + End If + + ' 检测lcfw映射 + If ContainsLcfwChange(strOrig, strConv) Then + details.Add "lcfw值映射" + End If + + ' 检测括号简化 + If CountOccurrences(strOrig, "(") > CountOccurrences(strConv, "(") Then + details.Add "括号简化" + End If + + ' 组合说明 + If details.count = 0 Then + AnalyzeConversion = "无变化" + Else + Dim result As String + result = "" + Dim item As Variant + For Each item In details + If Len(result) > 0 Then result = result & " + " + result = result & item + Next item + AnalyzeConversion = result + End If +End Function + +' ============================================================================== +' 辅助函数: DetermineStatus +' 职责: 确定转换状态 +' ============================================================================== +Private Function DetermineStatus( _ + ByVal strOrig As String, _ + ByVal strConv As String, _ + ByVal strCat As String _ +) As String + If Len(Trim(strOrig)) = 0 Then + DetermineStatus = "空条件" + ElseIf strCat <> "接头" Then + DetermineStatus = "未转换" + ElseIf strOrig <> strConv Then + DetermineStatus = "成功" + Else + DetermineStatus = "未转换" + End If +End Function + +' ============================================================================== +' 辅助函数: CountOccurrences +' 职责: 计算子字符串在字符串中出现的次数 +' ============================================================================== +Private Function CountOccurrences( _ + ByVal strText As String, _ + ByVal strFind As String _ +) As Long + If Len(strText) = 0 Or Len(strFind) = 0 Then + CountOccurrences = 0 + Exit Function + End If + CountOccurrences = (Len(strText) - Len(Replace(strText, strFind, ""))) / Len(strFind) +End Function + +' ============================================================================== +' 辅助函数: ContainsAzxsChange +' 职责: 使用正则表达式检查azxs值是否变化 +' ============================================================================== +Private Function ContainsAzxsChange( _ + ByVal strOrig As String, _ + ByVal strConv As String _ +) As Boolean + ' 使用正则表达式检查azxs值是否变化 + Dim regex As Object + Set regex = CreateObject("VBScript.RegExp") + + regex.Global = True + regex.IgnoreCase = True + regex.Pattern = "(azxs)( *=|!= *)([a-zA-Z0-9]{2})" + + ' 提取原始azxs值 + Dim origMatches As Object + Set origMatches = regex.Execute(strOrig) + + ' 提取转换后azxs值 + Dim convMatches As Object + Set convMatches = regex.Execute(strConv) + + ' 如果数量不同,说明有变化 + If origMatches.count <> convMatches.count Then + ContainsAzxsChange = True + Exit Function + End If + + ' 比较值 + Dim i As Long + For i = 0 To origMatches.count - 1 + If origMatches(i).SubMatches(2) <> convMatches(i).SubMatches(2) Then + ContainsAzxsChange = True + Exit Function + End If + Next i + + ContainsAzxsChange = False +End Function + +' ============================================================================== +' 辅助函数: ContainsLcfwChange +' 职责: 使用正则表达式检查lcfw值是否变化 +' ============================================================================== +Private Function ContainsLcfwChange( _ + ByVal strOrig As String, _ + ByVal strConv As String _ +) As Boolean + ' 使用正则表达式检查lcfw值是否变化 + Dim regex As Object + Set regex = CreateObject("VBScript.RegExp") + + regex.Global = True + regex.IgnoreCase = True + regex.Pattern = "(lcfw)( *=|!= *)([a-zA-Z]\d{1,3})" + + ' 提取原始lcfw值 + Dim origMatches As Object + Set origMatches = regex.Execute(strOrig) + + ' 提取转换后lcfw值 + Dim convMatches As Object + Set convMatches = regex.Execute(strConv) + + ' 如果数量不同,说明有变化 + If origMatches.count <> convMatches.count Then + ContainsLcfwChange = True + Exit Function + End If + + ' 比较值 + Dim i As Long + For i = 0 To origMatches.count - 1 + If origMatches(i).SubMatches(2) <> convMatches(i).SubMatches(2) Then + ContainsLcfwChange = True + Exit Function + End If + Next i + + ContainsLcfwChange = False +End Function + +' ============================================================================== +' 辅助函数: ExtractMappingDetails +' 职责: 提取并生成映射详情字符串 +' ============================================================================== +Private Function ExtractMappingDetails( _ + ByVal strOrig As String, _ + ByVal strConv As String _ +) As String + Dim mappings As Collection + Set mappings = New Collection + + ' 提取 azxs 映射 + Dim azxsMappings As String + azxsMappings = ExtractFieldMappings(strOrig, strConv, "azxs", "(azxs)( *=|!= *)([a-zA-Z0-9]{2})") + If Len(azxsMappings) > 0 Then + mappings.Add azxsMappings + End If + + ' 提取 lcfw 映射 + Dim lcfwMappings As String + lcfwMappings = ExtractFieldMappings(strOrig, strConv, "lcfw", "(lcfw)( *=|!= *)([a-zA-Z]\d{1,3})") + If Len(lcfwMappings) > 0 Then + mappings.Add lcfwMappings + End If + + ' 组合所有映射(使用换行符分隔) + If mappings.count = 0 Then + ExtractMappingDetails = "" + ElseIf mappings.count = 1 Then + ExtractMappingDetails = mappings(1) + Else + Dim result As String + result = "" + Dim item As Variant + For Each item In mappings + If Len(result) > 0 Then result = result & vbLf + result = result & item + Next item + ExtractMappingDetails = result + End If +End Function + +' ============================================================================== +' 辅助函数: ExtractFieldMappings +' 职责: 提取特定字段的映射详情 +' ============================================================================== +Private Function ExtractFieldMappings( _ + ByVal strOrig As String, _ + ByVal strConv As String, _ + ByVal fieldName As String, _ + ByVal pattern As String _ +) As String + ' 使用正则表达式提取字段映射 + Dim regex As Object + Set regex = CreateObject("VBScript.RegExp") + + regex.Global = True + regex.IgnoreCase = True + regex.Pattern = pattern + + ' 从原始条件中提取所有该字段的值 + Dim origMatches As Object + Set origMatches = regex.Execute(strOrig) + + ' 如果原始条件中没有匹配,返回空 + If origMatches.count = 0 Then + ExtractFieldMappings = "" + Exit Function + End If + + ' 收集所有唯一的映射 + Dim mappingDict As Object + Set mappingDict = CreateObject("Scripting.Dictionary") + + Dim i As Long + For i = 0 To origMatches.count - 1 + Dim origValue As String + Dim mappedValue As String + origValue = origMatches(i).SubMatches(2) + + ' 根据字段名查询映射表 + If LCase(fieldName) = "azxs" Then + mappedValue = M05_PreProcessor.GetAzxsMappedValue(origValue) + ElseIf LCase(fieldName) = "lcfw" Then + mappedValue = M05_PreProcessor.GetLcfwMappedValue(origValue) + Else + mappedValue = "" + End If + + ' 只有当找到映射且值发生变化时才记录 + If Len(mappedValue) > 0 And origValue <> mappedValue Then + Dim mapKey As String + mapKey = fieldName & "=" & origValue & " → " & fieldName & "=" & mappedValue + + ' 去重 + If Not mappingDict.Exists(mapKey) Then + mappingDict.Add mapKey, mapKey + End If + End If + Next i + + ' 组合结果 + If mappingDict.count = 0 Then + ExtractFieldMappings = "" + Else + Dim result As String + result = "" + Dim key As Variant + For Each key In mappingDict.keys + If Len(result) > 0 Then result = result & vbLf + result = result & key + Next key + ExtractFieldMappings = result + End If +End Function + +' ============================================================================== +' 辅助函数: WorksheetExists +' 职责: 检查工作表是否存在 +' ============================================================================== +Private Function WorksheetExists(ByVal sheetName As String) As Boolean + On Error Resume Next + Dim ws As Worksheet + Set ws = ActiveWorkbook.Sheets(sheetName) + WorksheetExists = Not ws Is Nothing + On Error GoTo 0 +End Function \ No newline at end of file