Xin hỗ trợ code vba cân bằng hàng hóa theo số lượng

[Together11]

Xin chào các bác, em là thành viên mới.
Em có bài toán như thế này nhờ các bác trong diễn đàn code VBA giúp em ạ.
Cụ thể là việc phân chia lại số lượng hàng hóa của các kho theo mốc cân bằng hàng hóa dựa vào tiêu chí.
Với mỗi mã hàng, thứ tự ưu tiên từ :
+ Kho nhiều nhất chuyển sang kho ít nhất cho đến điểm cân bằng hàng hóa
+ Nếu số liệu bằng nhau thì lấy từ trái sang phải.
Cụ thể chi tiết trong file nhờ các bác hỗ trợ ạ.
Em xin cảm ơn!

 

[HieuCD]

Xin chào các bác, em là thành viên mới.
Em có bài toán như thế này nhờ các bác trong diễn đàn code VBA giúp em ạ.
Cụ thể là việc phân chia lại số lượng hàng hóa của các kho theo mốc cân bằng hàng hóa dựa vào tiêu chí.
Với mỗi mã hàng, thứ tự ưu tiên từ :
+ Kho nhiều nhất chuyển sang kho ít nhất cho đến điểm cân bằng hàng hóa
+ Nếu số liệu bằng nhau thì lấy từ trái sang phải.
Cụ thể chi tiết trong file nhờ các bác hỗ trợ ạ.
Em xin cảm ơn!

Chạy sub XYZ . . .

Option Explicit
Sub XYZ()
  Dim arr(), aMH(), res(), ch(), thoat As Boolean
  Dim d#, t#, vMax#, vMin#, jMax&, jMin&
  Dim eRow&, sRow&, sKho&, eCol&, sCol&, i&, j&, k&
  Const tMin# = 1000000 'Lon hon Gia tri ton kho Lon nhat
  Const tMax# = -1000000 'Nho hon Gia tri ton kho Nho nhat
 
  eRow = Range("D5").End(xlDown).Row
  sRow = eRow - Range("D5").Row
  eCol = Range("D5").End(xlToRight).Column
  sCol = (eCol - Range("F1").Column + 1) / 2
  res = Range("F6").Resize(sRow, sCol).Value
  aMH = Range("D5").Resize(sRow + 1, sCol + 2).Value
  arr = Range("F6").Offset(, sCol).Resize(sRow, sCol).Value
 
  ReDim ch(1 To sRow * sCol, 1 To 4)
  For i = 1 To sRow
    thoat = False
    Do
      Call FindMin(res, arr, vMin, tMin, jMin, sCol, i, j)
      If vMin < tMin Then
        d = arr(i, jMin) - vMin
        Do
          Call FindMax(res, arr, vMax, tMax, jMax, sCol, i, j)
          If vMax > tMax Then
            t = vMax - arr(i, jMax)
            k = k + 1
            ch(k, 1) = aMH(i + 1, 1)
            ch(k, 2) = aMH(1, jMax + 2)
            ch(k, 3) = aMH(1, jMin + 2)
            If t >= d Then
              res(i, jMin) = res(i, jMin) + d
              res(i, jMax) = res(i, jMax) - d
              ch(k, 4) = ch(k, 4) + d
              Exit Do
            Else
              res(i, jMin) = res(i, jMin) + t
              res(i, jMax) = res(i, jMax) - t
              ch(k, 4) = ch(k, 4) + t
              d = d - t
            End If
          Else
            thoat = True
            Exit Do
          End If
        Loop
      Else
        Exit Do
      End If
    Loop Until thoat = True
  Next i
  Range("D" & eRow + 4).Resize(sRow + 1, sCol + 2).Value = aMH
  Range("F" & eRow + 5).Resize(sRow, sCol).Value = res
  i = Range("AC1000000").End(xlUp).Row
  If i > 5 Then Range("AC6:AF" & i).ClearContents
  Range("AC6").Resize(k, 4).Value = ch
End Sub

Private Sub FindMin(res, arr, vMin, tMin, jMin, sCol, i, j)
  vMin = tMin
  For j = 1 To sCol
    If res(i, j) < arr(i, j) Then
      If vMin > res(i, j) Then
        vMin = res(i, j)
        jMin = j
      End If
    End If
  Next j
End Sub

Private Sub FindMax(res, arr, vMax, tMax, jMax, sCol, i, j)
  vMax = tMax
  For j = 1 To sCol
    If res(i, j) > arr(i, j) Then
      If vMax < res(i, j) Then
        vMax = res(i, j)
        jMax = j
      End If
    End If
  Next j
End Sub

 

[Together11]

Chạy sub XYZ . . .

Option Explicit
Sub XYZ()
  Dim arr(), aMH(), res(), ch(), thoat As Boolean
  Dim d#, t#, vMax#, vMin#, jMax&, jMin&
  Dim eRow&, sRow&, sKho&, eCol&, sCol&, i&, j&, k&
  Const tMin# = 1000000 'Lon hon Gia tri ton kho Lon nhat
  Const tMax# = -1000000 'Nho hon Gia tri ton kho Nho nhat
 
  eRow = Range("D5").End(xlDown).Row
  sRow = eRow - Range("D5").Row
  eCol = Range("D5").End(xlToRight).Column
  sCol = (eCol - Range("F1").Column + 1) / 2
  res = Range("F6").Resize(sRow, sCol).Value
  aMH = Range("D5").Resize(sRow + 1, sCol + 2).Value
  arr = Range("F6").Offset(, sCol).Resize(sRow, sCol).Value
 
  ReDim ch(1 To sRow * sCol, 1 To 4)
  For i = 1 To sRow
    thoat = False
    Do
      Call FindMin(res, arr, vMin, tMin, jMin, sCol, i, j)
      If vMin < tMin Then
        d = arr(i, jMin) - vMin
        Do
          Call FindMax(res, arr, vMax, tMax, jMax, sCol, i, j)
          If vMax > tMax Then
            t = vMax - arr(i, jMax)
            k = k + 1
            ch(k, 1) = aMH(i + 1, 1)
            ch(k, 2) = aMH(1, jMax + 2)
            ch(k, 3) = aMH(1, jMin + 2)
            If t >= d Then
              res(i, jMin) = res(i, jMin) + d
              res(i, jMax) = res(i, jMax) - d
              ch(k, 4) = ch(k, 4) + d
              Exit Do
            Else
              res(i, jMin) = res(i, jMin) + t
              res(i, jMax) = res(i, jMax) - t
              ch(k, 4) = ch(k, 4) + t
              d = d - t
            End If
          Else
            thoat = True
            Exit Do
          End If
        Loop
      Else
        Exit Do
      End If
    Loop Until thoat = True
  Next i
  Range("D" & eRow + 4).Resize(sRow + 1, sCol + 2).Value = aMH
  Range("F" & eRow + 5).Resize(sRow, sCol).Value = res
  i = Range("AC1000000").End(xlUp).Row
  If i > 5 Then Range("AC6:AF" & i).ClearContents
  Range("AC6").Resize(k, 4).Value = ch
End Sub

Private Sub FindMin(res, arr, vMin, tMin, jMin, sCol, i, j)
  vMin = tMin
  For j = 1 To sCol
    If res(i, j) < arr(i, j) Then
      If vMin > res(i, j) Then
        vMin = res(i, j)
        jMin = j
      End If
    End If
  Next j
End Sub

Private Sub FindMax(res, arr, vMax, tMax, jMax, sCol, i, j)
  vMax = tMax
  For j = 1 To sCol
    If res(i, j) > arr(i, j) Then
      If vMax < res(i, j) Then
        vMax = res(i, j)
        jMax = j
      End If
    End If
  Next j
End Sub

Cảm ơn bác rất nhiều ạ, kq ra hoàn toàn chính xác.
Chúc bác và ae GPE thật nhiều sức khỏe ạ.