VB Code to calculate amount from transfer of inventory

[rizmomin]

Hello:

Please refer to attached file.
I have data as shown.
This data shows inventory transfer from one store to another.
Column B and C are Store name.
Column G is Qty transfer and column H is Unot cost and Column I is total cost.

I need VB Code to do following

I need to create Invoice for each store for what they owe to each other.
My logic here is as below.

1st sort out the data for same 2 stores transfer (from and to, To and From).

Example
Row#2 and 3 shows Transfer from BN to WE (Cost is $6 and $14.40 = $20.40)
Now look for any transfer from WE to BN
Row#25 and #27 shows transfer from WE to BN (Cost is $21.60 and $42 = $63.60).

So now i would need output in sheet2 as shown

Let me know if you have any questions.
Thanks.

Riz

[rizmomin]

Hello:

Please refer to attached file.

I have shown the output needed as shown in sheet3 Let me know if you have any questions.
Thanks.

R

[karedog]

Maybe :

Sub Test()
  Dim cell As Range, a, b, i As Long, j As Long, str1 As String, str2 As String, strNumFormat As String, total As Single, v1, v2, z As New Collection

  Sheets.Add after:=Sheets(Sheets.Count)
  Set cell = ActiveSheet.Range("A1")

  With Sheets("Sheet1").Range("A1").CurrentRegion
    a = .Value
    strNumFormat = .Cells(2, 9).NumberFormat
    For i = 2 To UBound(a, 1)
        str1 = a(i, 2) & Chr$(2) & a(i, 3)
        str2 = a(i, 3) & Chr$(2) & a(i, 2)
        On Error Resume Next
           v1 = z(str1)
           If Err.Number = 0 Then v1(1).Add i: GoTo skipper
           Err.Clear
           v1 = z(str2)
           If Err.Number = 0 Then v1(2).Add i: GoTo skipper
           Err.Clear
           z.Add Key:=str1, Item:=Array(str1, New Collection, New Collection)
           z(str1)(1).Add i
skipper:
        On Error GoTo 0
    Next i

    For Each v1 In z
        total = 0
        i = 0

        ReDim b(1 To v1(1).Count + v1(2).Count + 2, 1 To UBound(a, 2))
        For Each v2 In v1(1)
            i = i + 1
            For j = 1 To UBound(a, 2)
                b(i, j) = a(v2, j)
            Next j
            total = total - a(v2, 9)
        Next v2
        For Each v2 In v1(2)
            i = i + 1
            For j = 1 To UBound(a, 2)
                b(i, j) = a(v2, j)
            Next j
            total = total + a(v2, 9)
        Next v2
        i = i + 2
        b(i, 1) = "According to above"
        b(i, 2) = "Invoice"
        b(i, 3) = b(1, 2)
        b(i, 4) = "to Pay"
        b(i, 5) = b(1, 3)
        b(i, 6) = ">>>>>>>>>>>>>>>>>>>>'"
        b(i, 9) = total

        .Rows(1).Copy cell
        cell.Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
        Set cell = cell.Offset(UBound(b, 1) + 3)
    Next v1
  End With
  
  With cell.Parent.UsedRange
    .EntireColumn.AutoFit
    .Columns("H:I").NumberFormat = strNumFormat
  End With
End Sub

[rizmomin]

Hello Karedog:

Great Job, Thanks but i am seeing small issue.
Let me explain.
Inventory is transfered FROM and TO stores
So inventory moving FROM store gets $$ from TO Store

So refer to Sheet4 which was created by your code.
Here look at the data in Row 10 & 11
In this case 2 item # inventory is moved from EL to WE, totalling $15
SO in this case WE needs to pay EL as i have highlighted.

Go down to data from row 24 down.
Here Row# 26 thru 36 : Inventory is moved from LJ to WE totalling $106.
Now Row#37 shows : Inventory moved from WE to LJ totalling $6.
So in this case, WE will pay $100

Go down Row 58
Inventory moved FROM SO to CW, so CW to pay SO $3.00 and so on.


SO now once this is done, if code can be modified to give me summary as shown in column L thru O.

Please let me know if you have any questions.
Thanks.

Riz

[karedog]

Hi Riz,

So you mean, you always want a positive number for total ?
Then use this modified code :

Sub Test()
  Dim cell As Range, a, b, c, i As Long, j As Long, str1 As String, str2 As String, strNumFormat As String, total As Single, v1, v2, z1 As New Collection, z2 As New Collection, z3 As New Collection

  Sheets.Add after:=Sheets(Sheets.Count)
  Set cell = ActiveSheet.Range("A1")

  With Sheets("Sheet1").Range("A1").CurrentRegion
    a = .Value
    strNumFormat = .Cells(2, 9).NumberFormat
    For i = 2 To UBound(a, 1)
        str1 = a(i, 2) & Chr$(2) & a(i, 3)
        str2 = a(i, 3) & Chr$(2) & a(i, 2)
        On Error Resume Next
           v1 = z1(str1)
           If Err.Number = 0 Then v1(1).Add i: GoTo skipper
           Err.Clear
           v1 = z1(str2)
           If Err.Number = 0 Then v1(2).Add i: GoTo skipper
           Err.Clear
           z1.Add Key:=str1, Item:=Array(str1, New Collection, New Collection)
           z1(str1)(1).Add i
skipper:
        On Error GoTo 0
    Next i

    For Each v1 In z1
        total = 0
        i = 0
 
        c = Split(v1(0), Chr$(2))
        For Each v2 In v1(1): total = total - a(v2, 9): Next v2
        For Each v2 In v1(2): total = total + a(v2, 9): Next v2
        If total >= 0 Then
           Set z2 = v1(1)
           Set z3 = v1(2)
        Else
           Set z2 = v1(2)
           Set z3 = v1(1)
           total = Abs(total)
           v2 = c(0): c(0) = c(1): c(1) = v2
        End If
        
        ReDim b(1 To z2.Count + z3.Count + 2, 1 To UBound(a, 2))
        For Each v2 In z2
            i = i + 1
            For j = 1 To UBound(a, 2)
                b(i, j) = a(v2, j)
            Next j
        Next v2
        For Each v2 In z3
            i = i + 1
            For j = 1 To UBound(a, 2)
                b(i, j) = a(v2, j)
            Next j
        Next v2
        i = i + 2
        b(i, 1) = "According to above"
        b(i, 2) = "Invoice"
        b(i, 3) = c(0)
        b(i, 4) = "to Pay"
        b(i, 5) = c(1)
        b(i, 6) = ">>>>>>>>>>>>>>>>>>>>'"
        b(i, 9) = total

        .Rows(1).Copy cell
        cell.Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
        Set cell = cell.Offset(UBound(b, 1) + 3)
    Next v1
  End With
  
  With cell.Parent.UsedRange
    .EntireColumn.AutoFit
    .Columns("H:I").NumberFormat = strNumFormat
  End With
End Sub

[rizmomin]

Hello karedog:

Seems like you got it.

SO now once this is done, if code can be modified to give me summary as shown in column L thru O.

Please refer to sheet5 of attached sheet.

Riz

[karedog]

Should be :

Sub Test()
  Dim cell As Range, a, b, c, d, i As Long, j As Long, k As Long, str1 As String, str2 As String, strNumFormat As String, total As Single, v1, v2, z1 As New Collection, z2 As New Collection, z3 As New Collection

  Sheets.Add after:=Sheets(Sheets.Count)
  Set cell = ActiveSheet.Range("A1")

  With Sheets("Sheet1").Range("A1").CurrentRegion
    a = .Value
    strNumFormat = .Cells(2, 9).NumberFormat
    For i = 2 To UBound(a, 1)
        str1 = a(i, 2) & Chr$(2) & a(i, 3)
        str2 = a(i, 3) & Chr$(2) & a(i, 2)
        On Error Resume Next
           v1 = z1(str1)
           If Err.Number = 0 Then v1(1).Add i: GoTo skipper
           Err.Clear
           v1 = z1(str2)
           If Err.Number = 0 Then v1(2).Add i: GoTo skipper
           Err.Clear
           z1.Add Key:=str1, Item:=Array(str1, New Collection, New Collection)
           z1(str1)(1).Add i
skipper:
        On Error GoTo 0
    Next i

    k = 1
    ReDim d(1 To z1.Count + 1, 1 To 4)
    d(1, 1) = "Date"
    d(1, 2) = "Pay From"
    d(1, 3) = "Pay to"
    d(1, 4) = "Amount"

    For Each v1 In z1
        total = 0
        i = 0

        c = Split(v1(0), Chr$(2))
        For Each v2 In v1(1): total = total - a(v2, 9): Next v2
        For Each v2 In v1(2): total = total + a(v2, 9): Next v2
        If total >= 0 Then
           Set z2 = v1(1)
           Set z3 = v1(2)
        Else
           Set z2 = v1(2)
           Set z3 = v1(1)
           total = Abs(total)
           v2 = c(0): c(0) = c(1): c(1) = v2
        End If
        
        ReDim b(1 To z2.Count + z3.Count + 2, 1 To UBound(a, 2))
        For Each v2 In z2
            i = i + 1
            For j = 1 To UBound(a, 2)
                b(i, j) = a(v2, j)
            Next j
        Next v2
        For Each v2 In z3
            i = i + 1
            For j = 1 To UBound(a, 2)
                b(i, j) = a(v2, j)
            Next j
        Next v2
        i = i + 2
        b(i, 1) = "According to above"
        b(i, 2) = "Invoice"
        b(i, 3) = c(0)
        b(i, 4) = "to Pay"
        b(i, 5) = c(1)
        b(i, 6) = ">>>>>>>>>>>>>>>>>>>>'"
        b(i, 9) = total
        k = k + 1
        d(k, 1) = b(1, 1)
        d(k, 2) = c(0)
        d(k, 3) = c(1)
        d(k, 4) = total

        .Rows(1).Copy cell
        cell.Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
        Set cell = cell.Offset(UBound(b, 1) + 3)
    Next v1
  End With
  
  With cell.Parent.UsedRange
    .EntireColumn.AutoFit
    .Columns("H:I").NumberFormat = strNumFormat
  End With
  With cell.Parent.Range("L1").Resize(UBound(d, 1), UBound(d, 2))
    .Value = d
    .Borders.Weight = xlThin
    .EntireColumn.AutoFit
    .Columns(4).NumberFormat = strNumFormat
  End With
End Sub

[rizmomin]

Hello Karedog:

Thanks a lot...this will work

R