内容由 AI 生成
Sub AdjustInventoryQty_NewAlgorithm()
Dim originalSheetName As String
originalSheetName = "库龄超过6个月" ' 原表名称
Dim newWs As Worksheet ' 新表对象
Dim ws As Worksheet ' 原表对象
Dim invCheckWs As Worksheet ' 存货盘点明细表对象
Dim targetSheetName As String ' 目标表名
' ========== 1. 用户输入调整列号(金额列) ==========
Dim amountColLetter As String
amountColLetter = InputBox("请输入需调整的金额列号(如 K):", "输入列号", "K")
If amountColLetter = "" Then
MsgBox "列号不能为空!", vbExclamation
Exit Sub
End If
Dim amountCol As Long ' 转换为数字列号
On Error Resume Next
amountCol = Columns(amountColLetter).Column ' 验证列号有效性
On Error GoTo 0
If amountCol = 0 Then
MsgBox "无效的列号:" & amountColLetter, vbExclamation
Exit Sub
End If
' ========== 2. 检查原表是否存在 ==========
On Error Resume Next
Set ws = ThisWorkbook.Sheets(originalSheetName)
On Error GoTo 0
If ws Is Nothing Then
MsgBox "未找到名为【" & originalSheetName & "】的工作表!", vbExclamation
Exit Sub
End If
' ========== 3. 初始化目标表名(临时) ==========
targetSheetName = originalSheetName & "-调整后-" & amountColLetter & "-" & Format(0, "0.00")
' ========== 4. 处理新表创建/复用 ==========
Dim tempWs As Worksheet
On Error Resume Next
Set tempWs = ThisWorkbook.Sheets(targetSheetName)
On Error GoTo 0
' ========== 5. 计算当前金额汇总(使用用户输入列) ==========
Dim CurrentSum As Double, Target As Double
Dim LastRow As Long, DataStartRow As Long, DataEndRow As Long
LastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row ' H列为数量列(固定)
DataStartRow = 6
DataEndRow = LastRow - 1
CurrentSum = 0
If DataEndRow >= DataStartRow Then
Dim i As Long
For i = DataStartRow To DataEndRow
' 条件判断:产成品 + 金额列非空 + 单价非空且非0
If ws.Cells(i, "B").Value = "产成品" And _
ws.Cells(i, amountCol).Value <> "" And _
ws.Cells(i, "G").Value <> "" And _
ws.Cells(i, "G").Value <> 0 Then
CurrentSum = CurrentSum + ws.Cells(i, amountCol).Value
End If
Next i
End If
' ========== 6. 输入目标金额 ==========
On Error Resume Next
Target = InputBox("请输入目标金额:", "目标金额", CurrentSum)
On Error GoTo 0
If Target = 0 Then
MsgBox "目标金额不能为0!", vbExclamation
Exit Sub
End If
If Target = CurrentSum Then
MsgBox "当前金额已等于目标,无需调整!", vbInformation
Exit Sub
End If
' ========== 7. 更新目标表名(最终) ==========
targetSheetName = originalSheetName & "-调整后-" & amountColLetter & "-" & Format(Target, "0.00")
' ========== 8. 处理表名重复 ==========
On Error Resume Next
Set newWs = ThisWorkbook.Sheets(targetSheetName)
On Error GoTo 0
If Not newWs Is Nothing Then
' 存在重复表:清空并复制原表数据
newWs.UsedRange.Clear
ws.Cells.Copy newWs.Cells(1, 1)
Else
' 新建表
ws.Copy After:=ws
Set newWs = ThisWorkbook.ActiveSheet
newWs.Name = targetSheetName
End If
' ========== 9. 删除新表形状(如按钮) ==========
Dim shp As Shape
For Each shp In newWs.Shapes
shp.Delete
Next shp
' ========== 10. 筛选有效行(复用用户输入列) ==========
LastRow = newWs.Cells(newWs.Rows.Count, "H").End(xlUp).Row
DataStartRow = 6
DataEndRow = LastRow - 1
If DataEndRow < DataStartRow Then
MsgBox "未找到有效数据行!", vbExclamation
newWs.Delete
Exit Sub
End If
' 收集有效行索引
Dim validRows() As Long, rowCount As Long
ReDim validRows(1 To 1000)
rowCount = 0
For i = DataStartRow To DataEndRow
If newWs.Cells(i, "B").Value = "产成品" And _
newWs.Cells(i, amountCol).Value <> "" And _
newWs.Cells(i, "G").Value <> "" And _
newWs.Cells(i, "G").Value <> 0 Then
rowCount = rowCount + 1
validRows(rowCount) = i
End If
Next i
If rowCount = 0 Then
MsgBox "无符合条件的可调整行!", vbExclamation
newWs.Delete
Exit Sub
End If
ReDim Preserve validRows(1 To rowCount)
' ========== 11. 提取单价和数量 ==========
Dim prices() As Double, qtys() As Long
ReDim prices(1 To rowCount)
ReDim qtys(1 To rowCount)
For i = 1 To rowCount
prices(i) = newWs.Cells(validRows(i), "G").Value ' 单价(G列固定)
qtys(i) = newWs.Cells(validRows(i), "H").Value ' 数量(H列固定)
Next i
' ========== 12. 计算误差并寻找调整策略 ==========
Dim Delta As Double: Delta = Target - CurrentSum
Dim absDelta As Double: absDelta = Abs(Delta)
MsgBox "检测到误差:" & Format(Delta, "0.00") & vbCrLf & "正在寻找调整策略...", vbInformation
Dim maxCombinations As Long: maxCombinations = rowCount
Dim found As Boolean: found = False
Dim comboSize As Long
Dim adjustIndices() As Long, adjustQty() As Long, adjustCount As Long
For comboSize = 1 To maxCombinations
If FindAdjustment(prices, qtys, rowCount, comboSize, Delta, absDelta, adjustIndices, adjustQty, adjustCount) Then
found = True
Exit For
End If
Next comboSize
' ========== 13. 执行调整(若找到策略) ==========
If found Then
Dim oldQty As Long, newQty As Long
Dim oldAmount As Double, newAmount As Double
Dim unitPrice As Double
Dim adjustDetails As String: adjustDetails = ""
Dim adjustedItems As Object
Set adjustedItems = CreateObject("Scripting.Dictionary")
For i = 1 To adjustCount
Dim rowIndex As Long: rowIndex = adjustIndices(i)
Dim actualRow As Long: actualRow = validRows(rowIndex)
unitPrice = prices(rowIndex)
oldQty = qtys(rowIndex)
newQty = oldQty + adjustQty(i)
oldAmount = newWs.Cells(actualRow, amountCol).Value
newAmount = unitPrice * newQty
' 更新数量(H列)和金额(用户列)
newWs.Cells(actualRow, "H").Value = newQty
newWs.Cells(actualRow, amountCol).Value = newAmount
newWs.Cells(actualRow, amountCol).Interior.Color = RGB(255, 0, 0)
' 记录物料编码
Dim materialCode As String: materialCode = newWs.Cells(actualRow, "D").Value
adjustDetails = adjustDetails & "第" & actualRow & "行:" & _
oldQty & " → " & newQty & "(" & IIf(adjustQty(i) > 0, "+", "") & adjustQty(i) & ")," & _
"单价:" & Format(unitPrice, "0.00") & vbCrLf
adjustedItems(materialCode) = newQty
Next i
' ========== 14. 同步到存货盘点明细表(固定K列) ==========
Dim syncDetails As String: syncDetails = vbCrLf & "存货盘点明细表同步结果:" & vbCrLf
Dim invLastRow As Long, invRow As Long
Dim material As Variant
Dim matched As Boolean
' 匹配表头:调整后表的【用户列第5行】 vs 盘点表第5行
Dim targetHeader As String: targetHeader = newWs.Cells(5, amountCol).Value
Dim checkCol As Long: checkCol = 0
On Error Resume Next
Set invCheckWs = ThisWorkbook.Sheets("存货盘点明细表")
On Error GoTo 0
If invCheckWs Is Nothing Then
syncDetails = syncDetails & "未找到【存货盘点明细表】,无法同步!"
Else
' 取消筛选
If invCheckWs.AutoFilterMode Then
invCheckWs.ShowAllData
invCheckWs.AutoFilterMode = False
End If
invLastRow = invCheckWs.Cells(invCheckWs.Rows.Count, "B").End(xlUp).Row
If invLastRow < 6 Then
syncDetails = syncDetails & "盘点表数据不足(需≥6行),无法同步!"
Else
' 遍历盘点表第5行找匹配表头
Dim headerLastCol As Long
headerLastCol = invCheckWs.Cells(5, invCheckWs.Columns.Count).End(xlToLeft).Column
For i = 1 To headerLastCol
If invCheckWs.Cells(5, i).Value = targetHeader Then
checkCol = i
Exit For
End If
Next i
If checkCol = 0 Then
syncDetails = syncDetails & "盘点表第5行未找到与【" & amountColLetter & "5】匹配的表头,无法同步!"
Else
' 遍历调整项,检查√后更新K列
For Each material In adjustedItems.Keys
matched = False
For invRow = 6 To invLastRow
If invCheckWs.Cells(invRow, "B").Value = material Then
If invCheckWs.Cells(invRow, checkCol).Value = "√" Then
invCheckWs.Cells(invRow, "K").Value = adjustedItems(material) ' 固定K列
syncDetails = syncDetails & "物料【" & material & "】已同步(行" & invRow & ",满足√)" & vbCrLf
matched = True
Else
syncDetails = syncDetails & "物料【" & material & "】找到行" & invRow & ",但未勾选√,不更新" & vbCrLf
End If
End If
Next invRow
If Not matched Then
syncDetails = syncDetails & "物料【" & material & "】未找到匹配行" & vbCrLf
End If
Next material
End If
End If
End If
' ========== 15. 最终汇总 & 提示 ==========
Dim finalSum As Double: finalSum = 0
For i = 1 To rowCount
finalSum = finalSum + newWs.Cells(validRows(i), amountCol).Value
Next i
MsgBox "调整完成!表名:" & newWs.Name & vbCrLf & vbCrLf & _
"调整详情:" & vbCrLf & adjustDetails & vbCrLf & _
"原金额:" & Format(CurrentSum, "0.00") & " → 目标:" & Format(Target, "0.00") & " → 调整后:" & Format(finalSum, "0.00") & vbCrLf & _
syncDetails, vbInformation
Else
MsgBox "未找到有效调整策略!", vbExclamation
newWs.Delete
End If
End Sub
' ========== 以下为辅助函数(保持不变) ==========
Function FindAdjustment(prices() As Double, qtys() As Long, totalItems As Long, _
comboSize As Long, Delta As Double, absDelta As Double, _
ByRef adjustIndices() As Long, ByRef adjustQty() As Long, ByRef adjustCount As Long) As Boolean
Dim indices() As Long
ReDim indices(1 To comboSize)
If GenerateCombinations(1, 1, totalItems, comboSize, indices, prices, qtys, Delta, absDelta, adjustIndices, adjustQty, adjustCount) Then
FindAdjustment = True
Exit Function
End If
FindAdjustment = False
End Function
Function GenerateCombinations(currentPos As Long, startIndex As Long, totalItems As Long, _
comboSize As Long, indices() As Long, prices() As Double, _
qtys() As Long, Delta As Double, absDelta As Double, _
ByRef adjustIndices() As Long, ByRef adjustQty() As Long, ByRef adjustCount As Long) As Boolean
Dim i As Long
If currentPos > comboSize Then
If CheckCombination(indices, comboSize, prices, qtys, Delta, absDelta, adjustIndices, adjustQty, adjustCount) Then
GenerateCombinations = True
Else
GenerateCombinations = False
End If
Exit Function
End If
For i = startIndex To totalItems
indices(currentPos) = i
If GenerateCombinations(currentPos + 1, i + 1, totalItems, comboSize, indices, prices, qtys, Delta, absDelta, adjustIndices, adjustQty, adjustCount) Then
GenerateCombinations = True
Exit Function
End If
Next i
GenerateCombinations = False
End Function
Function CheckCombination(indices() As Long, comboSize As Long, prices() As Double, _
qtys() As Long, Delta As Double, absDelta As Double, _
ByRef adjustIndices() As Long, ByRef adjustQty() As Long, ByRef adjustCount As Long) As Boolean
Dim signs() As Long
ReDim signs(1 To comboSize)
If GenerateSignCombinations(1, comboSize, signs, indices, prices, qtys, Delta, absDelta, adjustIndices, adjustQty, adjustCount) Then
CheckCombination = True
Else
CheckCombination = False
End If
End Function
Function GenerateSignCombinations(currentPos As Long, comboSize As Long, signs() As Long, _
indices() As Long, prices() As Double, qtys() As Long, _
Delta As Double, absDelta As Double, _
ByRef adjustIndices() As Long, ByRef adjustQty() As Long, ByRef adjustCount As Long) As Boolean
Dim i As Long
Dim sumSigns As Long
Dim S As Double
If currentPos > comboSize Then
sumSigns = 0
For i = 1 To comboSize
sumSigns = sumSigns + signs(i)
Next i
If sumSigns <> 0 Then
GenerateSignCombinations = False
Exit Function
End If
S = 0
For i = 1 To comboSize
S = S + signs(i) * prices(indices(i))
Next i
If Abs(S) < absDelta And Abs(S) > 0 Then
Dim K As Double: K = Delta / S
If Abs(K - Round(K, 0)) < 0.0001 Then
K = Round(K, 0)
Dim valid As Boolean: valid = True
For i = 1 To comboSize
If qtys(indices(i)) + K * signs(i) < 0 Then
valid = False
Exit For
End If
Next i
If valid Then
ReDim adjustIndices(1 To comboSize)
ReDim adjustQty(1 To comboSize)
adjustCount = comboSize
For i = 1 To comboSize
adjustIndices(i) = indices(i)
adjustQty(i) = K * signs(i)
Next i
GenerateSignCombinations = True
Exit Function
End If
End If
End If
GenerateSignCombinations = False
Exit Function
End If
signs(currentPos) = 1
If GenerateSignCombinations(currentPos + 1, comboSize, signs, indices, prices, qtys, Delta, absDelta, adjustIndices, adjustQty, adjustCount) Then
GenerateSignCombinations = True
Exit Function
End If
signs(currentPos) = -1
If GenerateSignCombinations(currentPos + 1, comboSize, signs, indices, prices, qtys, Delta, absDelta, adjustIndices, adjustQty, adjustCount) Then
GenerateSignCombinations = True
Exit Function
End If
GenerateSignCombinations = False
End Function
我写了宏代码,帮客户(个人非企业)处理表格,这个报价多少合适
最新发布