' ============================================================================== ' 模块: M02_DataIO ' 职责: 数据读写 ' ============================================================================== Option Explicit Public Function ReadSourceData(ws As Worksheet) As Variant Dim lastRow As Long Dim i As Long, r As Long Dim arrRaw As Variant Dim arrResult() As Variant Dim cell As Range ' 查找C列最后一行(保持原有逻辑,使用代号列判断) lastRow = ws.Cells(ws.Rows.count, M04_Config.COL_IDX_CODE).End(xlUp).row If lastRow < M04_Config.SRC_START_ROW Then ReadSourceData = Empty Exit Function End If ' 第一步:使用数组方式读取整个数据区域(高性能) arrRaw = ws.Range(ws.Cells(M04_Config.SRC_START_ROW, 1), ws.Cells(lastRow, M04_Config.COL_IDX_CODE66)).Value ' 第二步:对66代码列(第9列)使用.Text属性重新读取,以保留前导0 ' 因为.Value会将"00123"转换为123,而.Text会保留显示的"00123" ReDim arrResult(1 To UBound(arrRaw, 1), 1 To UBound(arrRaw, 2)) ' 复制原始数据 For r = 1 To UBound(arrRaw, 1) For i = 1 To UBound(arrRaw, 2) If i = M04_Config.COL_IDX_CODE66 Then ' 对于66代码列(I列),使用.Text属性读取显示文本 Set cell = ws.Cells(M04_Config.SRC_START_ROW + r - 1, M04_Config.COL_IDX_CODE66) arrResult(r, i) = cell.Text Else ' 其他列使用原始值 arrResult(r, i) = arrRaw(r, i) End If Next i Next r ReadSourceData = arrResult End Function Public Sub WriteCategoryToNewBook(catData As Object) Dim newWb As Workbook Dim ws As Worksheet Dim catName As Variant Dim colRows As Collection Dim finalArr() As Variant Dim headerKeys As Collection Dim i As Long, r As Long, c As Long Dim rowDict As Object Dim key As Variant If catData.count = 0 Then Exit Sub Set newWb = Workbooks.Add For Each catName In catData.keys Set colRows = catData(catName) If colRows.count > 0 Then ' 创建新Sheet Set ws = newWb.Worksheets.Add ws.Name = CleanSheetName(CStr(catName)) ' 1. 扫描该类别所有Key Dim allKeysDict As Object Set allKeysDict = CreateObject("Scripting.Dictionary") For i = 1 To colRows.count ' colRows(i) 是一个 Array(Dict, BaseInfoArr) Set rowDict = colRows(i)(0) For Each key In rowDict.keys If Not allKeysDict.Exists(key) Then allKeysDict.Add key, 0 Next key Next i ' 2. 排序Key Dim sortedHeaders() As String sortedHeaders = SortHeaders(allKeysDict.keys) ' 3. 准备输出数组 Dim condCount As Long condCount = UBound(sortedHeaders) - LBound(sortedHeaders) + 1 ' 检查是否为空数组(如果全是无条件的物料) If sortedHeaders(0) = "" And condCount = 1 Then condCount = 0 Dim totalCols As Long totalCols = condCount + 3 ' 条件列 + 名称/编码/数量 ReDim finalArr(1 To colRows.count + 1, 1 To totalCols) ' 3.1 写表头 Dim colOffset As Long colOffset = 0 If condCount > 0 Then For c = 0 To condCount - 1 finalArr(1, c + 1) = sortedHeaders(c) Next c colOffset = condCount End If finalArr(1, colOffset + 1) = "名称" finalArr(1, colOffset + 2) = "编码" finalArr(1, colOffset + 3) = "数量" ' 3.2 填充内容 For r = 1 To colRows.count Dim baseInfo As Variant Set rowDict = colRows(r)(0) baseInfo = colRows(r)(1) ' Array: Code, Name, Qty ' 填条件 If condCount > 0 Then For c = 0 To condCount - 1 key = sortedHeaders(c) If rowDict.Exists(key) Then finalArr(r + 1, c + 1) = rowDict(key) End If Next c End If ' 填基础信息 finalArr(r + 1, colOffset + 1) = baseInfo(1) ' Name finalArr(r + 1, colOffset + 2) = baseInfo(0) ' Code finalArr(r + 1, colOffset + 3) = baseInfo(2) ' Qty Next r ' 4 设置编码列为文本格式(防止数字编码被转换为科学计数法或丢失前导零) ws.Columns(colOffset + 2).NumberFormat = "@" ' 4.1 写入Excel ws.Range("A1").Resize(UBound(finalArr, 1), UBound(finalArr, 2)).Value = finalArr ws.Range("A1").Resize(1, totalCols).Font.Bold = True ws.Columns.AutoFit End If Next catName MsgBox "处理完成!", vbInformation End Sub Private Function SortHeaders(keys As Variant) As String() ' 冒泡排序 Dim i As Long, j As Long Dim temp As String Dim arr() As String Dim count As Long count = UBound(keys) - LBound(keys) + 1 If count = 0 Then ReDim arr(0 To 0) arr(0) = "" SortHeaders = arr Exit Function End If ReDim arr(0 To count - 1) For i = 0 To count - 1 arr(i) = keys(i) Next i For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If M04_Config.GetHeaderPriority(arr(i)) > M04_Config.GetHeaderPriority(arr(j)) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next j Next i SortHeaders = arr End Function Private Function CleanSheetName(s As String) As String Dim invalid As String, i As Long invalid = ":\/?*[]" CleanSheetName = s For i = 1 To Len(invalid) CleanSheetName = Replace(CleanSheetName, Mid(invalid, i, 1), "_") Next i If Len(CleanSheetName) > 31 Then CleanSheetName = Left(CleanSheetName, 31) End Function