VBA for Purchase entry form

[Zubair]

Hi Experts,

I am making an Inventory Management file by looking at some online videos and stuck in the 1st part i.e. Purchase.

1st-row entries are moving perfectly from tab "Form" to tab "Dashboard" but do not know how to put formula so it can move more than 1 row in 1 purchase entry like 1 invoice many products, need help, please.

Form

Corrugated Carton Business Model test.xlsm
	D	E	F	G	H	I	J	K	L
2	Purchase Data Entry Form
3
4
5		Supplier Name					Invoice/Bill No.
6
7		Supplier No.		22005			Invoice Date
8
9	S. No.	Brand (Quality)		Gram	Quantity	Size	Weight	Rate	Amount
10	1								-
11	2								-
12	3								-
13	4								-
14	5								-
15	6								-
16	7								-
17	8								-
18	9								-
19	10								-
20	11								-
21	12								-
22	13								-
23	14								-
24	15								-
25	16								-
26	17								-
27	18								-
28	19								-
29	20								-
30	21								-
31	22								-
32	23								-
33	24								-
34								Subtotal	-
35					Vehicle No.			Cartage
36					Driver Name			TOTAL	-
37
Form

Cell Formulas
Range	Formula
L10:L33	L10	=+J10*K10
L34	L34	=SUM(L10:L33)
L36	L36	=+L35+L34

Cells with Data Validation
Cell	Allow	Criteria
G5:H5	List	='Supplier Details'!$B$4:$B$205
K7	List	='Supplier Details'!$M$4:$M$10595

Dashboard

Corrugated Carton Business Model test.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	S. No	Supplier No.	Supplier Name	Invoice/Bill No.	Invoice Date	Brand (Quantity)	Gram	Quantity	Size	Weight	Rate	Amount	Cartage	Vehicle No.	Driver Name	Submitted By	Submitted On
2	1	22005	Supplier No.95	10005	1/21/2022	Dubai	110	1	39	750	60	45,000	500	KZ1250	Driver 10	ZESSA-Click	22-01-2022 15:00:35
3	2	22005	Supplier No.100	10006	1/21/2022	Gold	115	1	36	850	65	55,250	250	KY1500	Driver 15	ZESSA-Click	22-01-2022 15:02:00
4
5
6
7
8
9
10
11
12
13
Database

VBA
Option Explicit

Function Validate() As Boolean

Dim frm As Worksheet

Set frm = ThisWorkbook.Sheets("Form")

Validate = True

With frm

.Range("G5").Interior.Color = xlNone
.Range("K5").Interior.Color = xlNone
.Range("K7").Interior.Color = xlNone
.Range("E10").Interior.Color = xlNone
.Range("G10").Interior.Color = xlNone
.Range("H10").Interior.Color = xlNone
.Range("I10").Interior.Color = xlNone
.Range("J10").Interior.Color = xlNone
.Range("K10").Interior.Color = xlNone
.Range("I35").Interior.Color = xlNone
.Range("I36").Interior.Color = xlNone
.Range("L35").Interior.Color = xlNone

End With

'Validating Supplier Name

If Trim(frm.Range("G5").Value) = "" Then
MsgBox "Supplier Name is blank.", vbOKOnly + vbInformation, "Supplier Name"
frm.Range("G5").Select
frm.Range("G5").Interior.Color = vbRed
Validate = False
Exit Function
End If


'Validating Invoice/Bill No.

If Trim(frm.Range("K5").Value) = "" Then
MsgBox "Invoice/Bill No. is blank.", vbOKOnly + vbInformation, "Invoice/Bill No."
frm.Range("K5").Select
frm.Range("K5").Interior.Color = vbRed
Validate = False
Exit Function
End If


'Validating Invoice Date

If Trim(frm.Range("K7").Value) = "" Then
MsgBox "Invoice Date is blank", vbOKOnly + vbInformation, "Invoice Date"
frm.Range("K7").Select
frm.Range("K7").Interior.Color = vbRed
Validate = False
Exit Function
End If



'Validating Brand (Quality)

If Trim(frm.Range("E10").Value) = "" Then
MsgBox "Quality is blank", vbOKOnly + vbInformation, "Brand (Quality)"
frm.Range("E10").Select
frm.Range("E10").Interior.Color = vbRed
Validate = False
Exit Function
End If


'Validating Gram

If Trim(frm.Range("G10").Value) = "" Or Not IsNumeric(Trim(frm.Range("G10").Value)) Then
MsgBox "Please ender valid Gram", vbOKOnly + vbInformation, "Gram"
frm.Range("G10").Select
frm.Range("G10").Interior.Color = vbRed
Validate = False
Exit Function

End If


'Validating Quantity

If Trim(frm.Range("H10").Value) = "" Or Not IsNumeric(Trim(frm.Range("H10").Value)) Then
MsgBox "Please ender valid Quantity", vbOKOnly + vbInformation, "Quantity"
frm.Range("H10").Select
frm.Range("H10").Interior.Color = vbRed
Validate = False
Exit Function

End If



'Validating Size

If Trim(frm.Range("I10").Value) = "" Or Not IsNumeric(Trim(frm.Range("I10").Value)) Then
MsgBox "Please ender valid Size", vbOKOnly + vbInformation, "Quantity"
frm.Range("I10").Select
frm.Range("I10").Interior.Color = vbRed
Validate = False
Exit Function

End If



'Validating Weight

If Trim(frm.Range("J10").Value) = "" Or Not IsNumeric(Trim(frm.Range("J10").Value)) Then
MsgBox "Please ender valid Weight", vbOKOnly + vbInformation, "Weight"
frm.Range("J10").Select
frm.Range("J10").Interior.Color = vbRed
Validate = False
Exit Function

End If

'Validating Rate

If Trim(frm.Range("K10").Value) = "" Or Not IsNumeric(Trim(frm.Range("K10").Value)) Then
MsgBox "Please ender valid Rate", vbOKOnly + vbInformation, "Rate"
frm.Range("K10").Select
frm.Range("K10").Interior.Color = vbRed
Validate = False
Exit Function

End If



'Validating Vehicle No.

If Trim(frm.Range("I35").Value) = "" Then
MsgBox "Vehicle No. is blank", vbOKOnly + vbInformation, "Vehicle No."
frm.Range("I35").Select
frm.Range("I35").Interior.Color = vbRed
Validate = False
Exit Function
End If



'Validating Driver Name

If Trim(frm.Range("I36").Value) = "" Then
MsgBox "Driver Name is blank", vbOKOnly + vbInformation, "Driver Name"
frm.Range("I36").Select
frm.Range("I36").Interior.Color = vbRed
Validate = False
Exit Function
End If


'Validating Carrtage

If Trim(frm.Range("L35").Value) = "" Then
MsgBox "Cartage is blank if no charges put zero", vbOKOnly + vbInformation, "Cartage"
frm.Range("L35").Select
frm.Range("L35").Interior.Color = vbRed
Validate = False
Exit Function
End If

End Function



Sub Reset()

With Sheets("Form")

.Range("G5").Interior.Color = xlNone
.Range("G5").Value = ""

.Range("K5").Interior.Color = xlNone
.Range("K5").Value = ""

.Range("K7").Interior.Color = xlNone
.Range("K7").Value = ""

.Range("E10:E24").Interior.Color = xlNone
.Range("E10:E24").Value = ""

.Range("G10").Interior.Color = xlNone
.Range("G10").Value = ""

.Range("H10").Interior.Color = xlNone
.Range("H10").Value = ""

.Range("I10").Interior.Color = xlNone
.Range("I10").Value = ""

.Range("J10").Interior.Color = xlNone
.Range("J10").Value = ""

.Range("K10").Interior.Color = xlNone
.Range("K10").Value = ""

.Range("I35").Interior.Color = xlNone
.Range("I35").Value = ""

.Range("I36").Interior.Color = xlNone
.Range("I36").Value = ""

.Range("L35").Interior.Color = xlNone
.Range("L35").Value = ""


End With

End Sub


Sub Save()

Dim frm As Worksheet
Dim database As Worksheet


Dim iRow As Long
Dim iSerial As Long

Set frm = ThisWorkbook.Sheets("Form")

Set database = ThisWorkbook.Sheets("Database")


If Trim(frm.Range("L1").Value) = "" Then

iRow = database.Range("A" & Application.Rows.Count).End(xlUp).Row + 1

If iRow = 2 Then

iSerial = 1

Else

iSerial = database.Cells(iRow - 1, 1).Value + 1

End If

Else

iRow = frm.Range("K1").Value
iSerial = frm.Range("L1").Value

End If

With database

.Cells(iRow, 1).Value = iSerial

.Cells(iRow, 2).Value = frm.Range("G7").Value

.Cells(iRow, 3).Value = frm.Range("G5").Value

.Cells(iRow, 4).Value = frm.Range("K5").Value

.Cells(iRow, 5).Value = frm.Range("K7").Value

.Cells(iRow, 6).Value = frm.Range("E10:E24").Value

.Cells(iRow, 7).Value = frm.Range("G10").Value

.Cells(iRow, 8).Value = frm.Range("H10").Value

.Cells(iRow, 9).Value = frm.Range("I10").Value

.Cells(iRow, 10).Value = frm.Range("J10").Value

.Cells(iRow, 11).Value = frm.Range("K10").Value

.Cells(iRow, 12).Value = frm.Range("L10").Value

.Cells(iRow, 13).Value = frm.Range("L35").Value

.Cells(iRow, 14).Value = frm.Range("I35").Value

.Cells(iRow, 15).Value = frm.Range("I36").Value

.Cells(iRow, 16).Value = Application.UserName

.Cells(iRow, 17).Value = [Text(Now(), "DD-MM-YYYY HH:MM:SS")]


End With


frm.Range("K1").Value = ""
frm.Range("L1").Value = ""



End Sub


Sub Modify()

Dim iRow As Long
Dim iSerial As Long


iSerial = Application.InputBox("Please enter Serial Number to make modification.", "Modify", , , , , , 1)

On Error Resume Next

iRow = Application.WorksheetFunction.IfError _
(Application.WorksheetFunction.Match(iSerial, Sheets("Database").Range("A:A"), 0), 0)

On Error GoTo 0

If iRow = 0 Then

MsgBox "No record found.", vbOKOnly + vbCritical, "No Record"
Exit Sub

End If


Sheets("Form").Range("K1").Value = iRow
Sheets("Form").Range("L1").Value = iSerial


Sheets("Form").Range("G5").Value = Sheets("Database").Cells(iRow, 3).Value

Sheets("Form").Range("K5").Value = Sheets("Database").Cells(iRow, 4).Value

Sheets("Form").Range("G7").Value = Sheets("Database").Cells(iRow, 2).Value

Sheets("Form").Range("K7").Value = Sheets("Database").Cells(iRow, 5).Value

Sheets("Form").Range("E10:E24").Value = Sheets("Database").Cells(iRow, 6).Value

Sheets("Form").Range("G10").Value = Sheets("Database").Cells(iRow, 7).Value

Sheets("Form").Range("H10").Value = Sheets("Database").Cells(iRow, 8).Value

Sheets("Form").Range("I10").Value = Sheets("Database").Cells(iRow, 9).Value

Sheets("Form").Range("J10").Value = Sheets("Database").Cells(iRow, 10).Value

Sheets("Form").Range("K10").Value = Sheets("Database").Cells(iRow, 11).Value

Sheets("Form").Range("L10").Value = Sheets("Database").Cells(iRow, 12).Value

Sheets("Form").Range("I35").Value = Sheets("Database").Cells(iRow, 13).Value

Sheets("Form").Range("I36").Value = Sheets("Database").Cells(iRow, 14).Value


End Sub


Sub DeleteRecord()

Dim iRow As Long
Dim iSerial As Long


iSerial = Application.InputBox("Please enter S.No. to delete the record.", "Delete", , , , , , 1)

On Error Resume Next

iRow = Application.WorksheetFunction.IfError _
(Application.WorksheetFunction.Match(iSerial, Sheets("Database").Range("A:A"), 0), 0)

On Error GoTo 0

If iRow = 0 Then

MsgBox "No record found.", vbOKOnly + vbCritical, "No Record"
Exit Sub

End If


Sheets("Database").Cells(iRow, 1).EntireRow.Delete shift:=xlUp


End Sub

 

[Zubair]

Hi mumps, Excellent, many thanks,

as instructed I have downloaded and run and found it according to my need, just wonder if the following are not appearing in Dashboard.

Driver Name, Vehicle No. & Cartage
It's not stopping or putting red when any field in Form is missing.
While putting more than 1 brand supplier no. and the name is appearing blank in Dashboard which is logical, but it will be good if it can repeat the same

 

[Zubair]

if person wrongly press botton "Save New" twice the entry is generating in Dashboard, better after save all fields should be blank for next entry

 

[mumps]

It's not stopping or putting red when any field in Form is missing.

I'm not sure why this part is not working for you. It works properly for me when I test the macro. Are you using the macros in the file I posted or in a different file?

Replace these 3 macros with the ones below:

Sub SaveNewData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, brand As Range
    Set srcWS = Sheets("Form")
    Set desWS = Sheets("Database")
    With srcWS
        For Each brand In .Range("E10", .Range("E" & .Rows.Count).End(xlUp))
            LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
            desWS.Range("A" & LastRow).Value = .Range("D" & brand.Row)
            desWS.Range("B" & LastRow).Resize(, 4).Value = Array(.Range("G7"), .Range("G5"), .Range("K5"), .Range("K7"))
            desWS.Range("F" & LastRow).Value = .Range("E" & brand.Row)
            desWS.Range("G" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
            desWS.Range("M" & LastRow).Resize(, 5).Value = Array(.Range("L35"), .Range("I35"), .Range("I36"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
        Next brand
    End With
    Call Reset
    Application.ScreenUpdating = True
End Sub

Sub SaveModData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, SN As Range, fndSN As Range
    Set srcWS = Sheets("Form")
    Set desWS = Sheets("Database")
    With srcWS
        For Each SN In .Range("D10", .Range("D" & .Rows.Count).End(xlUp))
            Set fndSN = desWS.Range("A:A").Find(SN, LookIn:=xlValues, lookat:=xlWhole)
            If Not fndSN Is Nothing Then
                With desWS
                    fndSN.Offset(, 1).Resize(, 4).Value = Array(Range("G7").Value, Range("G5").Value, Range("K5").Value, Range("K7").Value)
                    fndSN.Offset(, 5).Resize(, 7).Value = Array(Range("E" & SN.Row).Value, Range("G" & SN.Row).Value, Range("H" & SN.Row).Value, Range("I" & SN.Row).Value, Range("J" & SN.Row).Value, Range("K" & SN.Row).Value, Range("L" & SN.Row).Value)
                    .Range("M" & fndSN.Row).Resize(, 5).Value = Array(Range("L35"), Range("I35"), Range("I36"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
                End With
            Else
                With desWS
                    LastRow = .Range("D" & .Rows.Count).End(xlUp).Row + 1
                    .Range("A" & LastRow).Value = SN
                    .Range("B" & LastRow).Resize(, 4).Value = Array(Range("G7"), Range("G5"), Range("K5"), Range("K7"))
                    .Range("F" & LastRow).Value = Range("E" & SN.Row)
                    .Range("G" & LastRow).Resize(, 6).Value = Range("G" & SN.Row).Resize(, 6).Value
                    .Range("M" & LastRow).Resize(, 5).Value = Array(Range("L35"), Range("I35"), Range("I36"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
                    .Range("N" & LastRow) = Range("I35")
                    .Range("O" & LastRow) = Range("I36")
                    .Range("M" & LastRow) = Range("L35")
                End With
            End If
        Next SN
    End With
    Call Reset
    Application.ScreenUpdating = True
End Sub

Sub EditData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, INV As String, RowCount As Long, fVisRow As Long, lVisRow As Long
    Set srcWS = Sheets("Form")
    Set desWS = Sheets("Database")
    INV = Application.InputBox("Please enter Invoice No. you wish to modify.", "Modify", , , , , , 1)
    Set fnd = desWS.Range("D:D").Find(INV, LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        With desWS
            .Range("A1").CurrentRegion.AutoFilter 4, INV
            fVisRow = .AutoFilter.Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
            lVisRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            RowCount = .[subtotal(103,A:A)] - 1
            With srcWS
                .Range("G5").Value = fnd.Offset(, -1)
                .Range("K5").Value = INV
                .Range("G7").Value = fnd.Offset(, -2)
                .Range("K7").Value = fnd.Offset(, 1)
                .Range("D10:K33").ClearContents
                .Range("D10").Resize(RowCount).Value = desWS.Range("A" & fVisRow).Resize(RowCount).Value
                .Range("E10").Resize(RowCount).Value = desWS.Range("F" & fVisRow).Resize(RowCount).Value
                .Range("G10").Resize(RowCount, 5).Value = desWS.Range("G" & fVisRow).Resize(RowCount, 5).Value
                .Range("I35") = desWS.Range("N" & fVisRow)
                .Range("I36") = desWS.Range("O" & fVisRow)
                .Range("L35") = desWS.Range("M" & fVisRow)
            End With
            .Range("A1").AutoFilter
        End With
    Else
        MsgBox "No record found.", vbOKOnly + vbCritical, "No Record"
    End If
    Application.ScreenUpdating = True
End Sub

 

[Zubair]

Yes its working perfectly, many thanks.

As I mentioned purchase is the part of Inventory management, 2nd part is production, will ask your help till the whole project will be completed.

Hope you will support.

Thanks again.

 

[mumps]

You are very welcome.

 

[Zubair]

Now 2nd phase going to start I have added/changed the following tabs.

Changed tab from Form to Purchase
Added
1. Production
2. Sales
3. Stock Adjustment
4. Voucher
5. Reel stock
6. Accounts Receivable
7. Accounts Payable
8. Setup

Not known how to add excel file please guide

 

[mumps]

You could use the XL2BB add-in (icon in the menu) to attach screenshots (not a pictures) of your sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[Zubair]

Hi, mumps thanks,

You can see the file using the following link
in the 1st tab, a detail tab wise requirement mentioned

Corrugated Carton Business Model test 2.xlsm | Powered by Box

app.box.com

 

[mumps]

Although the first sheet describes the purpose of each of the other sheets, it is not helpful in describing how, when and the criteria for manipulating the data. It appears to me that you are requesting a much more sophisticated solution involving many sheets and large amounts of data which would involve much time and experience. My apologies, but I don't think that I have the time or experience to help any further. I think your request is more suitable to submit to this Forum's consulting service (cost involved) at this link: Consulting Services
Good luck with it.

 

[Zubair]

ok thanks