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