Running Inventory Using VBA

B

bradyman97

Board Regular
Joined
Feb 22, 2008
Messages
60
Office Version
  1. 2019
I'm new to VBA and was hoping someone could help me with a running inventory using a VBA code. I have 3 sheets (ProductList, Purchases, Transfers). What I am trying to do is calculate at CurrentBalance for each individual product (so far 500 products) in the ProductList. When I enter the data in the PurchaseQty and TransferQty I would like the current balance to change.



ProductList column headers are: ProductID, ProductName, CurrentBalance

Purchases column headers are: PurchaseDate, POnum, ProductID, ProductName, PurchaseQty, PurchasePrice, PurchaseTotal

Transfers column headers are: TransferDate, POnum, ProductID, ProductName, TransferQty, TransferPrice, TransferTotal
 
Sort by date Sort by votes
Hi Brady,

Please follow the link for update macro file : https://drive.google.com/open?id=17GDVbmt9ffDaU4okoNhBPhZmdbh9Dq7T

I have checked running successful with out any issues, on for few product ID's not in the purchase list but in the Transfer list, for those case you will get current balance as "-" dash , if you want to change it please modify only the below coding, if i using subtract function it will be shows negative value,

Thanks and please let me know for any further clarification



Code: 
ActiveCell.Offset(0, 2).Value = "-"


Regards,
Learn Excel in Tamil
 
Upvote 0

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Learn Excel in Tamil said:
Hi Brady,

Please follow the link for update macro file : https://drive.google.com/open?id=17GDVbmt9ffDaU4okoNhBPhZmdbh9Dq7T

I have checked running successful with out any issues, on for few product ID's not in the purchase list but in the Transfer list, for those case you will get current balance as "-" dash , if you want to change it please modify only the below coding, if i using subtract function it will be shows negative value,

Thanks and please let me know for any further clarification



Code: 
ActiveCell.Offset(0, 2).Value = "-"


Regards,
Learn Excel in Tamil
Click to expand...

Here is the complete coding which used on the file for reference

Code: 
Sub InventorCurrentbal()

Dim ProductID As String
Dim ProduceName As String
Dim PurchaseqtyTotal As Double
Dim TranferqtyTotal As Double
Dim CBPurchase As Double
Dim CBTranfer As Double
Application.StatusBar = "Please wait ... calculations in progress"

Worksheets("Productlist").Select
Range("A2").Select
Do While ActiveCell.Value <> ""
Application.ScreenUpdating = False
ProductID = ActiveCell.Value
Worksheets("Purchases").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter Field:=3, Criteria1:=ProductID
Selection.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add , After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "TmpPurchase"
Range("A1").PasteSpecial
Selection.Find(what:="PurchaseQty").Select
ProduceName = ActiveCell.Offset(1, -1).Value
ActiveCell.End(xlDown).Select
    If ActiveCell.Value <> "" Then
    Lastrow = ActiveCell.Address
    ActiveCell.Offset(1, 0).Value = "=Sum(E2: " & Lastrow & ")"
    CBPurchase = ActiveCell.Offset(1, 0).Value
    Else
    CBPurchase = "0"
    End If

Worksheets("Transfers").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter Field:=3, Criteria1:=ProductID
Selection.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add , After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "TmpTranfers"
Range("A1").PasteSpecial
Selection.Find(what:="TransferQty").Select
    If ProduceName = "" Then
    ProduceName = ActiveCell.Offset(1, -1).Value
    End If
ActiveCell.End(xlDown).Select
    If ActiveCell.Value <> "" Then
    Lastrow = ActiveCell.Address
    ActiveCell.Offset(1, 0).Value = "=Sum(E2: " & Lastrow & ")"
    CBTranfer = ActiveCell.Offset(1, 0).Value
    Else
    CBTranfer = "0"
    End If

Worksheets("Productlist").Select
ActiveCell.Offset(0, 1).Value = ProduceName

If CBPurchase = "0" Then
ActiveCell.Offset(0, 2).Value = "-"   ' Change coding if want
ElseIf CBTranfer = "0" Then
ActiveCell.Offset(0, 2).Value = CBPurchase
Else
ActiveCell.Offset(0, 2).Value = CBPurchase - CBTranfer
End If
Worksheets("Purchases").Select
Selection.AutoFilter
Worksheets("Transfers").Select
Selection.AutoFilter
Application.DisplayAlerts = False
Worksheets("Tmppurchase").Delete
Worksheets("TmpTranfers").Delete
Application.DisplayAlerts = True
Worksheets("Productlist").Select
ActiveCell.Offset(1, 0).Select

Loop

For i = 1 To Worksheets.Count

Worksheets(i).Select
Range("A1").Select
Next

Worksheets("Productlist").Select
Range("A1").Select

Application.StatusBar = ""
MsgBox "Macro Run sucessfully", vbInformation

End Sub
 
Upvote 0
Hi Learn Excel in Tamil,


Macro coding works great. Will this macro still work if I add more Purchases or Transfers or is there a range I need to change.


Thank you for your time with this macro coding
 
Upvote 0
Hi Brady,

Here is complete automated coding for your request, hope this will help you, please copy and replace my previous coding on module1 and run,

Please provide your feedback, for security reason, i am unable to post google drive links.

This code will update your produce list automatically and then add produce code and current balance as a output.

Thanks!
Learn excel in Tamil
Happy Learning!


Code: 
Sub InventorCurrentbal()

Dim ProductID As String
Dim ProduceName As String
Dim PurchaseqtyTotal As Double
Dim TranferqtyTotal As Double
Dim CBPurchase As Double
Dim CBTranfer As Double
Application.StatusBar = "Please wait ... calculations in progress"
Call AddnewproduceID

Worksheets("Productlist").Select
Range("A2").Select
Do While ActiveCell.Value <> ""
Application.ScreenUpdating = False
ProductID = ActiveCell.Value
Worksheets("Purchases").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter Field:=3, Criteria1:=ProductID
Selection.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add , After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "TmpPurchase"
Range("A1").PasteSpecial
Selection.Find(what:="PurchaseQty").Select
ProduceName = ActiveCell.Offset(1, -1).Value
ActiveCell.End(xlDown).Select
    If ActiveCell.Value <> "" Then
    Lastrow = ActiveCell.Address
    ActiveCell.Offset(1, 0).Value = "=Sum(E2: " & Lastrow & ")"
    CBPurchase = ActiveCell.Offset(1, 0).Value
    Else
    CBPurchase = "0"
    End If

Worksheets("Transfers").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter Field:=3, Criteria1:=ProductID
Selection.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add , After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "TmpTranfers"
Range("A1").PasteSpecial
Selection.Find(what:="TransferQty").Select
    If ProduceName = "" Then
    ProduceName = ActiveCell.Offset(1, -1).Value
    End If
ActiveCell.End(xlDown).Select
    If ActiveCell.Value <> "" Then
    Lastrow = ActiveCell.Address
    ActiveCell.Offset(1, 0).Value = "=Sum(E2: " & Lastrow & ")"
    CBTranfer = ActiveCell.Offset(1, 0).Value
    Else
    CBTranfer = "0"
    End If

Worksheets("Productlist").Select
ActiveCell.Offset(0, 1).Value = ProduceName

If CBPurchase = "0" Then
ActiveCell.Offset(0, 2).Value = "-"
ElseIf CBTranfer = "0" Then
ActiveCell.Offset(0, 2).Value = CBPurchase
Else
ActiveCell.Offset(0, 2).Value = CBPurchase - CBTranfer
End If
Worksheets("Purchases").Select
Selection.AutoFilter
Worksheets("Transfers").Select
Selection.AutoFilter
Application.DisplayAlerts = False
Worksheets("Tmppurchase").Delete
Worksheets("TmpTranfers").Delete
Application.DisplayAlerts = True
Worksheets("Productlist").Select
ActiveCell.Offset(1, 0).Select

Loop

For i = 1 To Worksheets.Count

Worksheets(i).Select
Range("A1").Select
Next

Worksheets("Productlist").Select
Range("A1").Select

Application.StatusBar = ""
MsgBox "Macro Run sucessfully", vbInformation

End Sub


Sub search_and_extract_singlecriteria()

Dim Purchases As Worksheet
Dim Transfers As Worksheet
Dim ProductHistory As Worksheet
Dim ProductID As String
Dim finalrow As Integer
Dim i As Integer

Set Purchases = Sheet2
Set ProductHistory = Sheet4
Set Transfers = Sheet3
ProductID = ProductHistory.Range("B2").Value

ProductHistory.Range("A5:H20000").ClearContents


Purchases.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row


For i = 2 To finalrow
    If Cells(i, 3) = ProductID Then
    Range(Cells(i, 1), Cells(i, 7)).Copy
    ProductHistory.Select
    Range("A20000").End(xlUp).Offset(1, 0).Select
     ActiveCell.PasteSpecial xlPasteFormulasAndNumberFormats
    ActiveCell.Offset(0, 7).Value = "Purchases"
    Purchases.Select
    End If
Next i


Transfers.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To finalrow
    If Cells(i, 3) = ProductID Then
    Range(Cells(i, 1), Cells(i, 7)).Copy
    ProductHistory.Select
    Range("A200000").End(xlUp).Offset(1, 0).Select
    ActiveCell.PasteSpecial xlPasteFormulasAndNumberFormats
    ActiveCell.Offset(0, 7).Value = "Tranfers"
        Transfers.Select
    End If
Next i

ProductHistory.Select


'Sort by data



Dim Lastrow As String
Worksheets("ProductHistory").Select
Lastrow = Range("A4").End(xlDown).Row

Range("A4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ProductHistory").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ProductHistory").Sort.SortFields.Add Key:=Range( _
        "A5:A" & Lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("ProductHistory").Sort
        .SetRange Range("A4:H" & Lastrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Range("B2").Select

MsgBox "Macro Run sucessfully", vbInformation



End Sub



Sub AddnewproduceID()

Worksheets("Purchases").Select
Range("C1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Temp"
Range("A1").PasteSpecial
Selection.RemoveDuplicates Columns:=1, Header:=xlYes
Range("B2").Select
ActiveCell.Offset(-1, 0).Value = "Temp"
ActiveCell.Value = "=VLOOKUP(A2,ProductList!A:A,1,0)"
ActiveCell.Offset(0, -1).End(xlDown).Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveCell.AutoFilter Field:=2, Criteria1:="#N/A"
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(Type:=xlCellTypeVisible).Copy

Worksheets("ProductList").Select
Range("A1").Offset(100000, 0).End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial
ActiveCell.EntireRow.Delete
Application.CutCopyMode = False
Application.DisplayAlerts = False
Worksheets("Temp").Delete
Application.DisplayAlerts = True
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Should I use VBA and/or make my formulas more efficient?
Replies
0
Views
1K
addms
A
R
  • Question Question
Generate dynamic templates with varying mandatory and non-mandatory fields depending on the product type chosen.
Replies
1
Views
1K
RajK2005
R
H
  • Question Question
VBA return header as text using column reference
Replies
1
Views
495
HeadAgainstABrickWall
H
E
  • Question Question
FIFO Macro giving different results each time it runs
Replies
7
Views
1K
Lee Wei Sin
L
X
  • Question Question
VBA to run a list all folder & subfolder content with column headers
2
Replies
10
Views
10K
Zot
Z

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top