Inventory transfer through VBA

[Zubair]

Mr. Excel.xlsx
	A	B	C	D	E	F	G	H	I	J
1	Inventory Data Form
2	Transaction	Inventory Transfer
3	Document No.	5001
4	Date	22/02/2022
5
6	Location From	Factory 1
7	Location To	Factory 2
8
9	Brand	Size	Quantity	Rate	Amount
10	ABC	21	25	60	1,500
11	CDE	29	12	55	660
12
13
14	Data base
15	Transaction	Document No.	Date	Location From	Location To	Brand	Size	Quantity	Rate	Amount
16	Opening stock				Factory 1	ABC	21	100	60	6,000
17	Opening stock				Factory 1	CDE	29	50	55	2,750
18
19	Inventory Transfer	5001	22/02/2022	Factory 1		ABC	21	-25	60	(1,500)
20	Inventory Transfer	5001	22/02/2022		Factory 2	ABC	21	25	60	1,500
21	Inventory Transfer	5001	22/02/2022	Factory 1		CDE	29	-12	55	(660)
22	Inventory Transfer	5001	22/02/2022		Factory 2	CDE	29	12	55	660
23
24	Closing stock				Factory 1	ABC	21	75	60	4,500
25	Closing stock				Factory 2	ABC	21	25	60	1,500
26	Closing stock				Factory 1	CDE	29	38	55	2,090
27	Closing stock				Factory 2	CDE	29	12	55	660
Inventory transfer

Cell Formulas
Range	Formula
J24:J27,J19:J22,J16:J17,E10:E11	E10	=+C10*D10
D19	D19	=+B6
E20	E20	=+B7
D21	D21	=+B6
E22	E22	=+B7
H24	H24	=+H16+H19
H25,H27	H25	=+H20
H26	H26	=+H17+H21

Hi,

I need VBA to record transfer stock from Factory 1 to Factory 2 in tab "database" through Inventory Data Form.
please help

 

[sijpie]

Hi Zubair, I was a bit busier than expected so some delay...

Read through the comments and set the correct sheet names and starting cells where the comments start with <<<<

Option Explicit

Sub TransferStock()
'Macro to show stock transfers in database
    Dim vIn As Variant, vOut As Variant, vDet As Variant
    Dim lRo As Long, lCo As Long, lRi As Long, lUBi As Long, lUBo As Long
    Dim rTransf As Range, rDB As Range
    
    Set rTransf = Sheets("Sheet1").Range("A9")      '<<<< Left  cell of heading row (Brand)
    vDet = Sheets("Sheet1").Range("A2:B7").Value    '<<<< address of Transaction table
    Set rDB = Sheets("Database").Range("A1")        '<<<< top Left  cell of database heading row
    
    'read data into arrays for fast processing
    vIn = rTransf.CurrentRegion.Value
    lUBi = UBound(vIn, 1)
    
    'set size of output array to correct number of rows (twice input)
    ReDim vOut(1 To 2 * (lUBi - 1), 1 To 10)
    
    lUBo = UBound(vOut, 1)
    lRi = 1     ' to account for header row
    ' Because each line of input  creates two lines of output, we use 'Step 2' in the loop
    For lRo = 1 To lUBo Step 2
        lRi = lRi + 1
        ' Decide what to do at each column for the two output rows
        For lCo = 1 To 10
            Select Case lCo
                Case 1, 2, 3
                    vOut(lRo, lCo) = vDet(lCo, 2)
                    vOut(lRo + 1, lCo) = vDet(lCo, 2)
                Case 4
                    vOut(lRo, lCo) = vDet(lCo + 1, 2)
                Case 5
                    vOut(lRo + 1, lCo) = vDet(lCo + 1, 2)
                Case 6, 7, 9
                    vOut(lRo, lCo) = vIn(lRi, lCo - 5)
                    vOut(lRo + 1, lCo) = vOut(lRo, lCo)
                Case 8, 10
                    vOut(lRo, lCo) = -vIn(lRi, lCo - 5)
                    vOut(lRo + 1, lCo) = -vOut(lRo, lCo)
            End Select
        Next lCo
    Next lRo
    
    ' Now dump the output array below the existing database
    rDB.Offset(rDB.CurrentRegion.Rows.Count, 0).Resize(lUBo, 10) = vOut
End Sub

 

[Zubair]

Hi Zubair, I was a bit busier than expected so some delay...

Read through the comments and set the correct sheet names and starting cells where the comments start with <<<<

Option Explicit

Sub TransferStock()
'Macro to show stock transfers in database
    Dim vIn As Variant, vOut As Variant, vDet As Variant
    Dim lRo As Long, lCo As Long, lRi As Long, lUBi As Long, lUBo As Long
    Dim rTransf As Range, rDB As Range
   
    Set rTransf = Sheets("Sheet1").Range("A9")      '<<<< Left  cell of heading row (Brand)
    vDet = Sheets("Sheet1").Range("A2:B7").Value    '<<<< address of Transaction table
    Set rDB = Sheets("Database").Range("A1")        '<<<< top Left  cell of database heading row
   
    'read data into arrays for fast processing
    vIn = rTransf.CurrentRegion.Value
    lUBi = UBound(vIn, 1)
   
    'set size of output array to correct number of rows (twice input)
    ReDim vOut(1 To 2 * (lUBi - 1), 1 To 10)
   
    lUBo = UBound(vOut, 1)
    lRi = 1     ' to account for header row
    ' Because each line of input  creates two lines of output, we use 'Step 2' in the loop
    For lRo = 1 To lUBo Step 2
        lRi = lRi + 1
        ' Decide what to do at each column for the two output rows
        For lCo = 1 To 10
            Select Case lCo
                Case 1, 2, 3
                    vOut(lRo, lCo) = vDet(lCo, 2)
                    vOut(lRo + 1, lCo) = vDet(lCo, 2)
                Case 4
                    vOut(lRo, lCo) = vDet(lCo + 1, 2)
                Case 5
                    vOut(lRo + 1, lCo) = vDet(lCo + 1, 2)
                Case 6, 7, 9
                    vOut(lRo, lCo) = vIn(lRi, lCo - 5)
                    vOut(lRo + 1, lCo) = vOut(lRo, lCo)
                Case 8, 10
                    vOut(lRo, lCo) = -vIn(lRi, lCo - 5)
                    vOut(lRo + 1, lCo) = -vOut(lRo, lCo)
            End Select
        Next lCo
    Next lRo
   
    ' Now dump the output array below the existing database
    rDB.Offset(rDB.CurrentRegion.Rows.Count, 0).Resize(lUBo, 10) = vOut
End Sub

Marvelous! Many thanks, sijpie. perfectly working as required.

Can I request you to see the following thread pending an answer long?

Data movement in 2 sheets

Hi, How can I move Purchase data in 2 sheets i.e. Datawarehouse and AP ? Purchase entry tab ABCDE1Document No.200032Date4/3/20223Supplier No.ProductQtyRateAmount458F42100858,500558F90105818,505658F991258911,12578910Subtotal28,13011Cartage50012Grand...

www.mrexcel.com