Public Sub GenerateStockProjection()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
' 定义工作表对象
Dim srcSheet As Worksheet, destSheet As Worksheet
Set srcSheet = ThisWorkbook.Sheets("推移表")
' 创建结果工作表
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("结果").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set destSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
destSheet.Name = "结果"
' 获取库存数据块信息
Dim stockHeaderRow As Long, lastRow As Long, lastCol As Long
lastRow = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row
stockHeaderRow = FindStockHeaderRow(srcSheet, lastRow)
If stockHeaderRow = 0 Then
MsgBox "未找到库存数据块", vbExclamation
Exit Sub
End If
' 获取日期范围
lastCol = srcSheet.Cells(stockHeaderRow, srcSheet.Columns.Count).End(xlToLeft).Column
Dim startDate As Date
startDate = srcSheet.Cells(stockHeaderRow, 3).value
' 准备结果表头
destSheet.Cells(1, 1).value = "零件编码"
Dim col As Long
For col = 1 To 15
destSheet.Cells(1, col + 1).value = startDate + (col - 1)
destSheet.Cells(1, col + 1).NumberFormat = "m/d"
Next col
' 创建字典存储数据
Dim dictStock As Object, dictOrder As Object, dictDemand As Object
Set dictStock = CreateObject("Scripting.Dictionary")
Set dictOrder = CreateObject("Scripting.Dictionary")
Set dictDemand = CreateObject("Scripting.Dictionary")
' 使用数组快速读取数据
ReadDataToDictionaries srcSheet, dictStock, dictOrder, dictDemand, stockHeaderRow, lastRow
' 处理并输出结果（只对计算过的行进行负值判断和前置）
ProcessAndOutputData destSheet, dictStock, dictOrder, dictDemand, startDate
' 格式化结果表
FormatResultSheet destSheet
ExitProcedure:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Exit Sub
ErrorHandler:
MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical
Resume ExitProcedure
End Sub
' 查找库存标题行
Private Function FindStockHeaderRow(ws As Worksheet, lastRow As Long) As Long
Dim r As Long
For r = 1 To lastRow
If UCase(Trim(ws.Cells(r, 2).value)) = "库存" Then
FindStockHeaderRow = r
Exit Function
End If
Next r
FindStockHeaderRow = 0
End Function
' 批量读取数据到字典
Private Sub ReadDataToDictionaries(ws As Worksheet, dictStock As Object, dictOrder As Object, dictDemand As Object, stockHeaderRow As Long, lastRow As Long)
Dim r As Long, partCode As String, status As String
Dim dataRange As Range
Set dataRange = ws.Range("A2:C" & lastRow)
' 使用数组一次性读取数据
Dim dataArray As Variant
dataArray = dataRange.value
' 处理所有数据行
Dim i As Long
For i = 1 To UBound(dataArray, 1)
partCode = Trim(CStr(dataArray(i, 1)))
status = Trim(CStr(dataArray(i, 2)))
If partCode <> "" And status <> "" Then
' 根据状态存储数据
Select Case UCase(status)
Case "库存"
dictStock(partCode) = CDbl(dataArray(i, 3))
Case "订单"
If Not dictOrder.Exists(partCode) Then
dictOrder.Add partCode, GetDailyValues(ws, stockHeaderRow, i + 1)
End If
Case "需求"
If Not dictDemand.Exists(partCode) Then
dictDemand.Add partCode, GetDailyValues(ws, stockHeaderRow, i + 1)
End If
End Select
End If
Next i
End Sub
' 获取每日值数组
Private Function GetDailyValues(ws As Worksheet, headerRow As Long, dataRow As Long) As Double()
Dim values(1 To 15) As Double
Dim col As Long
For col = 1 To 15
values(col) = ConvertToDouble(ws.Cells(dataRow, col + 2).value)
Next col
GetDailyValues = values
End Function
' 处理并输出数据（修改：只对计算过的行进行负值判断和前置）
Private Sub ProcessAndOutputData(destSheet As Worksheet, dictStock As Object, dictOrder As Object, dictDemand As Object, startDate As Date)
Dim partCodes() As Variant
partCodes = dictStock.keys
' 使用集合存储不同类型的行
Dim calculatedNegativeRows As New Collection ' 计算后有负值的行
Dim calculatedPositiveRows As New Collection ' 计算后无负值的行
Dim uncalculatedRows As New Collection ' 未计算的行（缺少订单或需求）
Dim stockValue As Double
Dim orderVals() As Double, demandVals() As Double
Dim rowData() As Variant
Dim hasNegative As Boolean
Dim hasCalculated As Boolean
' 处理每个零件
Dim partCode As Variant
For Each partCode In partCodes
ReDim rowData(1 To 16)
rowData(1) = partCode
hasNegative = False
hasCalculated = False
' 初始库存值
stockValue = dictStock(partCode)
rowData(2) = stockValue
' 检查是否存在订单和需求数据（只有两者都存在才计算）
If dictOrder.Exists(partCode) And dictDemand.Exists(partCode) Then
orderVals = dictOrder(partCode)
demandVals = dictDemand(partCode)
hasCalculated = True
' 计算后续库存
Dim colIndex As Long
For colIndex = 3 To 16
stockValue = stockValue + orderVals(colIndex - 2) - demandVals(colIndex - 2)
rowData(colIndex) = stockValue
If stockValue < 0 Then hasNegative = True
Next colIndex
Else
' 缺少订单或需求数据，不计算后续库存
For colIndex = 3 To 16
rowData(colIndex) = "" ' 留空
Next colIndex
End If
' 根据是否计算和负值情况分类
If hasCalculated Then
If hasNegative Then
calculatedNegativeRows.Add rowData
Else
calculatedPositiveRows.Add rowData
End If
Else
uncalculatedRows.Add rowData
End If
Next partCode
' 输出结果：先计算后有负值的行，再计算后无负值的行，最后未计算的行
Dim outputRow As Long: outputRow = 2
' 输出计算后有负值的行
For Each rowItem In calculatedNegativeRows
destSheet.Range("A" & outputRow).Resize(1, 16).value = rowItem
outputRow = outputRow + 1
Next rowItem
' 输出计算后无负值的行
For Each rowItem In calculatedPositiveRows
destSheet.Range("A" & outputRow).Resize(1, 16).value = rowItem
outputRow = outputRow + 1
Next rowItem
' 输出未计算的行
For Each rowItem In uncalculatedRows
destSheet.Range("A" & outputRow).Resize(1, 16).value = rowItem
outputRow = outputRow + 1
Next rowItem
' 标记负值（只标记计算过的行）
MarkNegativeValues destSheet, calculatedNegativeRows.Count, calculatedPositiveRows.Count, uncalculatedRows.Count
End Sub
' 标记负值单元格（修改：只标记计算过的行）
Private Sub MarkNegativeValues(ws As Worksheet, calcNegCount As Long, calcPosCount As Long, uncalcCount As Long)
Dim r As Long, c As Long
Dim startRow As Long, endRow As Long
' 只标记计算过的行（负值行和正值行）
startRow = 2
endRow = startRow + calcNegCount + calcPosCount - 1
For r = startRow To endRow
' 标记零件编码（如果属于负值行集合）
If r <= startRow + calcNegCount - 1 Then
ws.Cells(r, 1).Font.Color = RGB(255, 0, 0)
End If
' 标记负值单元格
For c = 2 To 16
If IsNumeric(ws.Cells(r, c).value) Then
If ws.Cells(r, c).value < 0 Then
ws.Cells(r, c).Font.Color = RGB(255, 0, 0)
End If
End If
Next c
Next r
End Sub
' 格式化结果表
Private Sub FormatResultSheet(ws As Worksheet)
' 设置标题格式
With ws.Rows(1)
.Font.Bold = True
.Interior.Color = RGB(200, 200, 255)
.HorizontalAlignment = xlCenter
End With
' 设置数字格式
With ws.Range("B2:Q" & ws.Rows.Count)
.NumberFormat = "#,##0"
.HorizontalAlignment = xlRight
End With
' 自动调整列宽
ws.Columns("A:Q").AutoFit
' 冻结窗格
ws.Range("B2").Select
ActiveWindow.FreezePanes = True
' 添加说明行
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Cells(lastRow + 1, 1).value = "说明："
ws.Cells(lastRow + 1, 2).value = "红色部分表示具有完整数据并计算后出现负值的零件"
End Sub
' 数值转换函数
Private Function ConvertToDouble(inputVal As Variant) As Double
If IsNumeric(inputVal) Then
ConvertToDouble = CDbl(inputVal)
Else
Select Case UCase(Trim(CStr(inputVal)))
Case "N/A", "NA", "-", "", "NULL"
ConvertToDouble = 0
Case Else
ConvertToDouble = Val(Replace(inputVal, ",", ""))
End Select
End If
End Function在这份代码的运行结果中，输出表”结果“中列标题的日期无法与源表推移表对应，要求生成的”结果“表应该与源表中的日期一致，请根据要求修改代码并生成一份完整的代码
最新发布
本文详细介绍了如何在Excel中创建新工作表、删除已有的、复制工作表以及修改工作表名称。此外，还讲解了冻结窗格和添加筛选功能的基本用法。深入理解这些技巧，提升工作效率。
扫一扫
479
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
