' ============================================================================== ' 模块: M02_DataIO ' 职责: 数据读写 ' ============================================================================== Option Explicit Public Function ReadSourceData(ws As Worksheet) As Variant Dim lastRow As Long ' 查找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 ' 读取整张表的数据区域 (假设列数不超过20列,足以覆盖到类别列) ReadSourceData = ws.Range(ws.Cells(M04_Config.SRC_START_ROW, 1), ws.Cells(lastRow, M04_Config.COL_IDX_CAT)).Value 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. 写入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