45d1c1780f
All checks were successful
NTFY Notification / notify (push) Successful in 11s
Standardize all VBA property and method names to lowercase for consistent code style: - Err object: Err.Description → err.Description, Err.Number → err.Number - Collection properties: .Count → .count - Range properties: .Rows.Count → .Rows.count, .Row → .row - Dictionary methods: .Keys → .keys, .Exists → .exists - Worksheet properties: .Sheets.Count → .Sheets.count - Fix typo: Thisworkbook.Path → ThisWorkbook.Path VBA is case-insensitive, but consistent lowercase convention improves readability. Co-Authored-By: Claude Sonnet 4.5 <noreply@anthropic.com>
212 lines
6.9 KiB
QBasic
212 lines
6.9 KiB
QBasic
' ==============================================================================
|
||
' 模块: 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
|
||
Dim savePath As String
|
||
Dim sheetToDelete As Worksheet
|
||
|
||
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
|
||
|
||
' 5. 删除默认工作表（Workbooks.Add 创建的空白工作表）
|
||
Application.DisplayAlerts = False ' 禁用删除确认对话框
|
||
For Each sheetToDelete In newWb.Worksheets
|
||
If sheetToDelete.Name Like "Sheet*" Then
|
||
sheetToDelete.Delete
|
||
End If
|
||
Next sheetToDelete
|
||
Application.DisplayAlerts = True
|
||
|
||
' 6. 保存工作簿为 BOM库.xlsx
|
||
savePath = ThisWorkbook.Path & Application.PathSeparator & "BOM库.xlsx"
|
||
|
||
' 如果文件已存在，先删除
|
||
If Dir(savePath) <> "" Then
|
||
Kill savePath
|
||
End If
|
||
|
||
newWb.SaveAs savePath, FileFormat:=xlOpenXMLWorkbook
|
||
newWb.Close SaveChanges:=False
|
||
|
||
MsgBox "处理完成！已保存至：" & vbCrLf & savePath, 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 |