Excel跨店库存转移宏优化需求：减少目标门店数量

现有功能与问题 #

现有VBA宏已实现以下库存转移核心功能：

• 识别标记“Yes”的发货门店
• 按商品+颜色匹配目标门店
• 按销量/库存排序目标门店优先级
• 库存阈值校验
• 确保单门店转移量≥15单位
• 刷新数据透视表

当前存在的问题：同一发货门店的多品类库存会被分配到多个目标门店，不符合集中化转移的需求。

核心优化目标 #

在保留原有规则（库存阈值、单转移量≥15、销量优先级等）的前提下，实现：

• 同一发货门店的多品类转移优先合并至最少数量的目标门店（允许选择次优门店以达成合并）
• 合并逻辑需嵌入转移校验流程，而非事后调整

调整思路 #

1. 按发货门店分组处理：先将所有待转移商品按发货门店归类，避免跨门店分散处理
2. 构建目标门店优先级池：为每个发货门店筛选符合商品颜色、库存阈值要求的目标门店，并按销量降序排序优先级
3. 优先全量合并分配：对当前发货门店的所有待转移总量，先尝试分配给最优目标门店——若该门店剩余库容能容纳全部量，且每个品类的转移量都≥15，则直接全量分配
4. 次优门店组合分配：若最优门店无法容纳全部，则依次尝试次优门店，优先分配能满足单品类≥15的部分量，直到所有待转移量分配完成
5. 嵌入原有校验流程：将合并逻辑放在转移量分配的前置环节，替代原有分散分配逻辑

关键代码修改示例 #

以下是核心逻辑的VBA代码调整（基于现有宏结构适配）：

Sub OptimizedInventoryTransfer()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, i As Long
    Dim shipStore As String, productGroupEndRow As Long
    Dim totalToTransfer As Double
    Dim targetStores As Collection, targetStore As Variant
    
    Set wsSource = ThisWorkbook.Sheets("库存数据")
    Set wsTarget = ThisWorkbook.Sheets("转移结果")
    
    ' 按发货门店排序，实现分组
    wsSource.Range("A1").CurrentRegion.Sort Key1:=wsSource.Range("A1"), Order1:=xlAscending, Header:=xlYes
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    i = 2 ' 跳过表头行
    
    Do While i <= lastRow
        shipStore = wsSource.Cells(i, "A").Value
        ' 找到当前发货门店的最后一行数据
        productGroupEndRow = wsSource.Range("A:A").Find(What:=shipStore, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious).Row
        ' 计算当前发货门店待转移总量（假设待转移量在D列）
        totalToTransfer = Application.Sum(wsSource.Range("D" & i & ":D" & productGroupEndRow))
        
        ' 获取符合条件的目标门店池（按销量降序）
        Set targetStores = GetSortedTargetStores(shipStore, wsSource.Cells(i, "C").Value) ' C列为商品颜色
        
        ' 尝试合并分配到最少门店
        For Each targetStore In targetStores
            Dim maxAcceptQty As Double
            maxAcceptQty = GetTargetStoreMaxAccept(targetStore) ' 获取目标门店剩余接收容量
            
            If maxAcceptQty >= totalToTransfer And IsAllProductsMeetMinQty(shipStore, targetStore) Then
                ' 全量合并到该门店
                WriteTransferResult shipStore, targetStore, wsSource.Range("A" & i & ":D" & productGroupEndRow)
                totalToTransfer = 0
                Exit For
            ElseIf maxAcceptQty >= 15 Then
                ' 分配部分量，优先满足单品类≥15
                Dim assignedQty As Double
                assignedQty = AssignPartialTransfer(shipStore, targetStore, maxAcceptQty, wsSource.Range("A" & i & ":D" & productGroupEndRow))
                totalToTransfer = totalToTransfer - assignedQty
                If totalToTransfer <= 0 Then Exit For
            End If
        Next targetStore
        
        ' 跳转到下一个发货门店
        i = productGroupEndRow + 1
    Loop
    
    ' 刷新数据透视表
    ThisWorkbook.Worksheets("库存透视表").PivotTables("PivotTable1").RefreshTable
End Sub

' 获取按销量降序排序的符合条件的目标门店
Function GetSortedTargetStores(shipStore As String, productColor As String) As Collection
    Dim col As New Collection
    Dim wsTargets As Worksheet, lastRow As Long, i As Long
    Dim tempArr As Variant, sortedArr As Variant
    
    Set wsTargets = ThisWorkbook.Sheets("目标门店数据")
    lastRow = wsTargets.Cells(wsTargets.Rows.Count, "A").End(xlUp).Row
    
    ' 筛选符合条件的门店：匹配颜色、库存未达阈值、非发货门店
    For i = 2 To lastRow
        If wsTargets.Cells(i, "C").Value = productColor _
            And wsTargets.Cells(i, "D").Value < wsTargets.Cells(i, "E").Value _
            And wsTargets.Cells(i, "A").Value <> shipStore Then
            col.Add Array(wsTargets.Cells(i, "A").Value, wsTargets.Cells(i, "F").Value) ' 门店名称、销量
        End If
    Next i
    
    ' 按销量降序排序目标门店（简单冒泡排序）
    Dim temp As Variant, j As Long
    For i = 1 To col.Count - 1
        For j = i + 1 To col.Count
            If col(i)(1) < col(j)(1) Then
                temp = col(i)
                col.Remove i
                col.Add temp, Before:=j
            End If
        Next j
    Next i
    
    ' 提取排序后的门店名称
    Set GetSortedTargetStores = New Collection
    For Each temp In col
        GetSortedTargetStores.Add temp(0)
    Next temp
End Function

' 检查当前发货门店的所有待转移商品，转移到目标门店时是否都满足≥15单位
Function IsAllProductsMeetMinQty(shipStore As String, targetStore As String) As Boolean
    Dim wsSource As Worksheet, lastRow As Long, i As Long
    Set wsSource = ThisWorkbook.Sheets("库存数据")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    IsAllProductsMeetMinQty = True
    For i = 2 To lastRow
        If wsSource.Cells(i, "A").Value = shipStore And wsSource.Cells(i, "B").Value = "Yes" Then
            If wsSource.Cells(i, "D").Value < 15 Then
                IsAllProductsMeetMinQty = False
                Exit Function
            End If
        End If
    Next i
End Function

' 全量写入转移结果
Sub WriteTransferResult(shipStore As String, targetStore As String, productRange As Range)
    Dim wsTarget As Worksheet, lastRow As Long, rng As Range
    Set wsTarget = ThisWorkbook.Sheets("转移结果")
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
    
    For Each rng In productRange.Rows
        wsTarget.Cells(lastRow, "A").Value = shipStore
        wsTarget.Cells(lastRow, "B").Value = targetStore
        wsTarget.Cells(lastRow, "C").Value = rng.Cells(1, "C").Value ' 商品颜色
        wsTarget.Cells(lastRow, "D").Value = rng.Cells(1, "D").Value ' 转移量
        lastRow = lastRow + 1
    Next rng
End Sub

' 分配部分转移量，优先满足单品类≥15
Function AssignPartialTransfer(shipStore As String, targetStore As String, maxAccept As Double, productRange As Range) As Double
    Dim assignedTotal As Double, rng As Range
    assignedTotal = 0
    
    For Each rng In productRange.Rows
        Dim qtyToAssign As Double
        qtyToAssign = Application.Min(rng.Cells(1, "D").Value, maxAccept - assignedTotal)
        
        ' 确保分配量≥15（若剩余待分配量不足15则跳过，留到下一个门店）
        If qtyToAssign >= 15 Then
            ' 写入转移结果
            Dim wsTarget As Worksheet, lastRow As Long
            Set wsTarget = ThisWorkbook.Sheets("转移结果")
            lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
            
            wsTarget.Cells(lastRow, "A").Value = shipStore
            wsTarget.Cells(lastRow, "B").Value = targetStore
            wsTarget.Cells(lastRow, "C").Value = rng.Cells(1, "C").Value
            wsTarget.Cells(lastRow, "D").Value = qtyToAssign
            
            assignedTotal = assignedTotal + qtyToAssign
            ' 标记已分配的量（可在源数据中标记避免重复分配）
            rng.Cells(1, "D").Value = rng.Cells(1, "D").Value - qtyToAssign
            
            If assignedTotal >= maxAccept Then Exit For
        End If
    Next rng
    
    AssignPartialTransfer = assignedTotal
End Function

' 获取目标门店的最大接收容量（库存阈值 - 当前库存）
Function GetTargetStoreMaxAccept(targetStore As String) As Double
    Dim wsTargets As Worksheet, rng As Range
    Set wsTargets = ThisWorkbook.Sheets("目标门店数据")
    Set rng = wsTargets.Range("A:A").Find(What:=targetStore, LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not rng Is Nothing Then
        GetTargetStoreMaxAccept = wsTargets.Cells(rng.Row, "E").Value - wsTargets.Cells(rng.Row, "D").Value ' 阈值 - 当前库存
    Else
        GetTargetStoreMaxAccept = 0
    End If
End Function

代码说明 #

• 新增按发货门店分组的处理逻辑，确保同一门店的多品类转移被集中处理
• 目标门店池按销量降序排序，优先尝试最优门店接收全量转移
• 嵌入单品类≥15的校验到合并分配流程，避免拆分出不符合要求的小批量转移
• 保留原有库存阈值校验、数据透视表刷新等功能

内容的提问来源于stack exchange，提问作者Diego Kersjes