Changes required in VBA code

Zubair · Apr 20, 2022

Hi,

I have 2 Input tabs 1. Purchase and 2. Sales
Output is transferred to Database & AP for Purchase and Database & AR for Sales

Changes are required as follows:

Database - Cartage to appear 1 time per document, currently appearing based on the Brand row input.

AP - Single entry required, currently appearing based on brand row input.
AR - Single entry required, currently appearing based on brand row input.

Please help to change the VBA code

Purchase

Test 2.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

1

Purchase

PU

2

Purchase Reel Data Entry Form

3

4

5

Location

Product

Reel

6

Reel

7

Supplier Name

Invoice/Bill No.

8

9

Rate selection

Invoice Date

10

11

Document No.

Brand

Gram

Weight

Size

Quantity

Rate

Amount

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

Remarks

Subtotal

-

37

Vehicle No.

Cartage

38

Driver Name

Total

-

39

40

41

Purchase Reel

Cell Formulas
Range	Formula
L12:L35	L12	=IFERROR(+J12K12H12,"")
L36	L36	=SUM(L12:L35)
L38	L38	=+L36+L37

Sales

Test 2.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

1

Sales

SA

2

Reel Sales Data Entry Form

3

4

5

Location

Product

Reel

6

Reel

7

Customer Name

Invoice/Bill No.

8

9

Rate Selection

Invoice Date

10

11

Document No.

Brand

Gram

Weight

Size

Quantity

Rate

Amount

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

Remarks

Subtotal

-

37

Vehicle No.

Cartage

38

Driver Name

TOTAL

-

39

40

41

Sales Reel

Cell Formulas
Range	Formula
L12:L35	L12	=IFERROR(+J12K12H12,"")
L36	L36	=SUM(L12:L35)
L38	L38	=+L37+L36

Database

Test 2.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

1

Document No.

Document type

Transaction

Supplier/Customer Name

Invoice No.

Invoice Date

Brand

Gram

Weight

Size

Quantity

Rate

Amount

Cartage

Vehicle No.

Driver Name

User ID

Transaction Date

Rate Selection

Remarks

Product

Location To

2

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

Alpha Kraft

101

740

21

100

125

9,250,000

58,400

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

From the price list

Reel

Factory 1

3

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

Box Board

102

741

23

200

100

14,820,000

58,400

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

From the price list

Reel

Factory 1

4

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

Delta

103

742

25

250

102

18,921,000

58,400

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

From the price list

Reel

Factory 1

5

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

Liner

104

752

27

140

67

7,053,760

58,400

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

From the price list

Reel

Factory 1

6

8600001

SA

Sales

Customer No.1

2001

1/1/2020

Alpha Kraft

101

740

21

10

205

1,517,000

54,200

JX8000

Driver 2

ZESSA-Click

18-04-2022 15:14:16

From the price list

Reel

Factory 1

7

8600001

SA

Sales

Customer No.1

2001

1/1/2020

Box Board

102

741

23

15

175

1,945,125

54,200

JX8000

Driver 2

ZESSA-Click

18-04-2022 15:14:16

From the price list

Reel

Factory 1

8

8600001

SA

Sales

Customer No.1

2001

1/1/2020

Delta

103

742

25

180

3,339,000

54,200

JX8000

Driver 2

ZESSA-Click

18-04-2022 15:14:17

From the price list

Reel

Factory 1

9

5600002

PU

Purchase

Supplier No.2

1005

1/2/2022

Box Board

100

700

25

150

70

7,350,000

50,000

JX8950

Driver No.5

ZESSA-Click

19-04-2022 00:00:27

Manual

Checking the transfer of data

Reel

Factory 1

10

5600002

PU

Purchase

Supplier No.2

1005

1/2/2022

Dubai

102

750

22

130

78

7,605,000

50,000

JX8950

Driver No.5

ZESSA-Click

19-04-2022 00:00:27

Manual

Checking the transfer of data

Reel

Factory 1

11

8600002

SA

Sales

Customer No.4

1006

20/02/2022

Liner

104

752

27

50

90

3,384,000

952,000

JX9820

Driver No.9

ZESSA-Click

19-04-2022 00:04:13

Manual

Checking sales data transfer

Reel

Factory 1

12

8600002

SA

Sales

Customer No.4

1006

20/02/2022

Delta

103

745

25

100

150

11,175,000

952,000

JX9820

Driver No.9

ZESSA-Click

19-04-2022 00:04:13

Manual

Checking sales data transfer

Reel

Factory 1

13

5600003

PU

Purchase

Supplier No.3

1009

20/03/2022

Delta

100

740

25

100

180

13,320,000

560,000

JX9000

Driver No.10

ZESSA-Click

20-04-2022 14:01:01

Manual

Checking the data transfer

Reel

Factory 2

14

5600003

PU

Purchase

Supplier No.3

1009

20/03/2022

Liner

101

741

26

150

91

10,114,650

560,000

JX9000

Driver No.10

ZESSA-Click

20-04-2022 14:01:01

Manual

Checking the data transfer

Reel

Factory 2

15

5600003

PU

Purchase

Supplier No.3

1009

20/03/2022

Dubai

102

742

27

180

80

10,684,800

560,000

JX9000

Driver No.10

ZESSA-Click

20-04-2022 14:01:01

Manual

Checking the data transfer

Reel

Factory 2

16

8600003

SA

Sales

Customer No.11

1008

20/04/2022

Dubai

102

742

27

15

180

2,003,400

540,000

JX8900

Driver No.11

ZESSA-Click

20-04-2022 14:44:21

Manual

Check transactions to other tabs

Reel

Factory 2

17

8600003

SA

Sales

Customer No.11

1008

20/04/2022

Liner

101

741

26

20

190

2,815,800

540,000

JX8900

Driver No.11

ZESSA-Click

20-04-2022 14:44:21

Manual

Check transactions to other tabs

Reel

Factory 2

Database

AP

Test 2.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

1

Document No.

Document type

Transaction

Supplier/Customer Name

Invoice No.

Invoice Date

Subtotal

Cartage

Amount

Vehicle No.

Driver Name

User ID

Transaction Date

Remarks

Product

Location To

2

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

50,044,760

58,400

50,103,160

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

Reel

Factory 1

3

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

50,044,760

58,400

50,103,160

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

Reel

Factory 1

4

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

50,044,760

58,400

50,103,160

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

Reel

Factory 1

5

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

50,044,760

58,400

50,103,160

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

Reel

Factory 1

6

5600002

PU

Purchase

Supplier No.2

1005

1/2/2022

14,955,000

50,000

15,005,000

JX8950

Driver No.5

ZESSA-Click

19-04-2022 00:00:27

Reel

Factory 1

7

5600002

PU

Purchase

Supplier No.2

1005

1/2/2022

14,955,000

50,000

15,005,000

JX8950

Driver No.5

ZESSA-Click

19-04-2022 00:00:27

Reel

Factory 1

8

5600003

PU

Purchase

Supplier No.3

1009

20/03/2022

34,119,450

560,000

34,679,450

JX9000

Driver No.10

ZESSA-Click

20-04-2022 14:01:01

Checking the data transfer

Reel

Factory 2

9

5600003

PU

Purchase

Supplier No.3

1009

20/03/2022

34,119,450

560,000

34,679,450

JX9000

Driver No.10

ZESSA-Click

20-04-2022 14:01:01

Checking the data transfer

Reel

Factory 2

10

5600003

PU

Purchase

Supplier No.3

1009

20/03/2022

34,119,450

560,000

34,679,450

JX9000

Driver No.10

ZESSA-Click

20-04-2022 14:01:01

Checking the data transfer

Reel

Factory 2

AP

AR

Test 2.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

1

Document No.

Document type

Transaction

Supplier/Customer Name

Invoice No.

Invoice Date

Subtotal

Cartage

Amount

Vehicle No.

Driver Name

User ID

Transaction Date

Remarks

Product

Location To

2

8600001

SA

Sales

Customer No.1

2001

1/1/2020

6,801,125

54,200

6,855,325

JX8000

Driver 2

ZESSA-Click

18-04-2022 15:14:16

Reel

Factory 1

3

8600001

SA

Sales

Customer No.1

2001

1/1/2020

6,801,125

54,200

6,855,325

JX8000

Driver 2

ZESSA-Click

18-04-2022 15:14:16

Reel

Factory 1

4

8600001

SA

Sales

Customer No.1

2001

1/1/2020

6,801,125

54,200

6,855,325

JX8000

Driver 2

ZESSA-Click

18-04-2022 15:14:17

Reel

Factory 1

5

8600002

SA

Sales

Customer No.4

1006

20/02/2022

14,559,000

952,000

15,511,000

JX9820

Driver No.9

ZESSA-Click

19-04-2022 00:04:13

Checking sales data transfer

Reel

Factory 1

6

8600002

SA

Sales

Customer No.4

1006

20/02/2022

14,559,000

952,000

15,511,000

JX9820

Driver No.9

ZESSA-Click

19-04-2022 00:04:13

Checking sales data transfer

Reel

Factory 1

7

8600003

SA

Sales

Customer No.11

1008

20/04/2022

4,819,200

540,000

5,359,200

JX8900

Driver No.11

ZESSA-Click

20-04-2022 14:44:21

Check transactions to other tabs

Reel

Factory 2

8

8600003

SA

Sales

Customer No.11

1008

20/04/2022

4,819,200

540,000

5,359,200

JX8900

Driver No.11

ZESSA-Click

20-04-2022 14:44:21

Check transactions to other tabs

Reel

Factory 2

AR

Purchase Module
Sub SaveNewDataPurchaseReel()
Application.ScreenUpdating = False
Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, brand As Range
Set srcWS = Sheets("Purchase Reel")
Set desWS = Sheets("Database")
Set abcWS = Sheets("AP")
With srcWS

For Each brand In .Range("E12", .Range("E" & .Rows.Count).End(xlUp))
LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1

desWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
desWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
desWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
desWS.Range("G" & LastRow).Value = .Range("E" & brand.Row)
desWS.Range("H" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
desWS.Range("N" & LastRow).Resize(, 5).Value = Array(.Range("L37"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
desWS.Range("S" & LastRow).Resize(, 1).Value = Array(.Range("F9"))
desWS.Range("T" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
desWS.Range("U" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
desWS.Range("V" & LastRow).Resize(, 1).Value = Array(.Range("F5"))

LastRow = abcWS.Range("E" & .Rows.Count).End(xlUp).Row + 1

abcWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
abcWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
abcWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
abcWS.Range("G" & LastRow).Resize(, 7).Value = Array(.Range("L36"), .Range("L37"), .Range("L38"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
abcWS.Range("N" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
abcWS.Range("O" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
abcWS.Range("P" & LastRow).Resize(, 1).Value = Array(.Range("F5"))

Next brand
End With
Call ResetPurchaseReel
Application.ScreenUpdating = True
End Sub

Sub ResetPurchaseReel()
Application.ScreenUpdating = False
Dim srcWS As Worksheet, desWS As Worksheet
Set srcWS = Sheets("Purchase Reel")
Set desWS = Sheets("Database")
With srcWS
.Range("F5,F7,F9,J7,J9").Interior.Color = xlNone
.Range("F5,F7,F9,J7,J9").Value = ""
.Range("D12:K35").Interior.Color = xlNone
.Range("D12:K35").Value = ""
.Range("I37:I38,L37,H36").Interior.Color = xlNone
.Range("I37:I38,L37,H36").Value = ""
End With
Application.ScreenUpdating = True
End Sub

Sales Module
Sub SaveNewDataSalesReel()
Application.ScreenUpdating = False
Dim LastRow As Long, scrsWS As Worksheet, desWS As Worksheet, brand As Range
Set scrsWS = Sheets("Sales Reel")
Set desWS = Sheets("Database")
Set sreWS = Sheets("AR")
With scrsWS
For Each brand In .Range("E12", .Range("E" & .Rows.Count).End(xlUp))
LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1

desWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
desWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
desWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
desWS.Range("G" & LastRow).Value = .Range("E" & brand.Row)
desWS.Range("H" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
desWS.Range("N" & LastRow).Resize(, 5).Value = Array(.Range("L37"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
desWS.Range("S" & LastRow).Value = .Range("F9")
desWS.Range("T" & LastRow).Value = .Range("H36")
desWS.Range("U" & LastRow).Value = .Range("J5")
desWS.Range("V" & LastRow).Value = .Range("F5")

LastRow = sreWS.Range("E" & .Rows.Count).End(xlUp).Row + 1

sreWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
sreWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
sreWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
sreWS.Range("G" & LastRow).Resize(, 7).Value = Array(.Range("L36"), .Range("L37"), .Range("L38"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
sreWS.Range("N" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
sreWS.Range("O" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
sreWS.Range("P" & LastRow).Resize(, 1).Value = Array(.Range("F5"))

Next brand
End With
Call ResetSalesReel
Application.ScreenUpdating = True
End Sub

Sub ResetSalesReel()
Application.ScreenUpdating = False
Dim scrsWS As Worksheet, desWS As Worksheet
Set scrsWS = Sheets("Sales Reel")
Set desWS = Sheets("Database")
With scrsWS
.Range("F5,F7,F9,J7,J9").Interior.Color = xlNone
.Range("F5,F7,F9,J7,J9").Value = ""
.Range("D12:K35").Interior.Color = xlNone
.Range("D12:K35").Value = ""
.Range("H36,I37,I38,L37").Interior.Color = xlNone
.Range("H36,I37,I38,L37").Value = ""

End With
Application.ScreenUpdating = True
End Sub

DanteAmor · Apr 20, 2022

If I understand correctly, you only want a single record in the database and a single record in AP. But I'm not sure what data goes in columns G to M in the database sheet. Try the following macro for DataPurchaseReel

VBA Code:

'Purchase Module
Sub SaveNewDataPurchaseReel()
  Application.ScreenUpdating = True
  Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, brand As Range
  Set srcWS = Sheets("Purchase Reel")
  Set desWS = Sheets("Database")
  Set abcWS = Sheets("AP")
  With srcWS
  'For Each brand In .Range("E12", .Range("E" & .Rows.Count).End(xlUp))
    LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
    
    desWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
    desWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
    desWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
'    desWS.Range("G" & LastRow).Value = .Range("E" & brand.Row)
'    desWS.Range("H" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
    desWS.Range("N" & LastRow).Resize(, 5).Value = Array(.Range("L37"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
    desWS.Range("S" & LastRow).Resize(, 1).Value = Array(.Range("F9"))
    desWS.Range("T" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
    desWS.Range("U" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
    desWS.Range("V" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
    
    LastRow = abcWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
    
    abcWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
    abcWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
    abcWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
    abcWS.Range("G" & LastRow).Resize(, 7).Value = Array(.Range("L36"), .Range("L37"), .Range("L38"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
    abcWS.Range("N" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
    abcWS.Range("O" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
    abcWS.Range("P" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
  'Next brand
  End With
  Call ResetPurchaseReel
  Application.ScreenUpdating = True
End Sub

Zubair · Apr 21, 2022

DanteAmor said:

If I understand correctly, you only want a single record in the database and a single record in AP. But I'm not sure what data goes in columns G to M in the database sheet. Try the following macro for DataPurchaseReel

VBA Code:

'Purchase Module
Sub SaveNewDataPurchaseReel()
  Application.ScreenUpdating = True
  Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, brand As Range
  Set srcWS = Sheets("Purchase Reel")
  Set desWS = Sheets("Database")
  Set abcWS = Sheets("AP")
  With srcWS
  'For Each brand In .Range("E12", .Range("E" & .Rows.Count).End(xlUp))
    LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
   
    desWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
    desWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
    desWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
'    desWS.Range("G" & LastRow).Value = .Range("E" & brand.Row)
'    desWS.Range("H" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
    desWS.Range("N" & LastRow).Resize(, 5).Value = Array(.Range("L37"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
    desWS.Range("S" & LastRow).Resize(, 1).Value = Array(.Range("F9"))
    desWS.Range("T" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
    desWS.Range("U" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
    desWS.Range("V" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
   
    LastRow = abcWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
   
    abcWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
    abcWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
    abcWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
    abcWS.Range("G" & LastRow).Resize(, 7).Value = Array(.Range("L36"), .Range("L37"), .Range("L38"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
    abcWS.Range("N" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
    abcWS.Range("O" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
    abcWS.Range("P" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
  'Next brand
  End With
  Call ResetPurchaseReel
  Application.ScreenUpdating = True
End Sub

Hi DanteAmor - Many thanks, the revised code you provided in ok for AP showing single record but for database I need all rows and single amount of cartage in 1st line like follows :

Database

Test 2.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

1

Document No.

Document type

Transaction

Supplier/Customer Name

Invoice No.

Invoice Date

Brand

Gram

Weight

Size

Quantity

Rate

Amount

Cartage

Vehicle No.

Driver Name

User ID

Transaction Date

Rate Selection

Remarks

Product

Location To

2

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

Alpha Kraft

101

740

21

100

125

9,250,000

58,400

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

From the price list

Reel

Factory 1

3

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

Box Board

102

741

23

200

100

14,820,000

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

From the price list

Reel

Factory 1

4

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

Delta

103

742

25

250

102

18,921,000

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

From the price list

Reel

Factory 1

5

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

Liner

104

752

27

140

67

7,053,760

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

From the price list

Reel

Factory 1

Database

AP

Test 2.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

1

Document No.

Document type

Transaction

Supplier/Customer Name

Invoice No.

Invoice Date

Subtotal

Cartage

Amount

Vehicle No.

Driver Name

User ID

Transaction Date

Remarks

Product

Location To

2

5600001

PU

Purchase

Supplier No.1

1001

1/1/2020

50,044,760

58,400

50,103,160

JX8070

Driver 1

ZESSA-Click

18-04-2022 15:11:28

Reel

Factory 1

AP

Same for AR

DanteAmor · Apr 21, 2022

Here is the updated code.

VBA Code:

'Purchase Module
Sub SaveNewDataPurchaseReel()
  Application.ScreenUpdating = True
  Dim LastRow As Long, brand As Range
  Dim abcWS As Worksheet, srcWS As Worksheet, desWS As Worksheet
  Set srcWS = Sheets("Purchase Reel")
  Set desWS = Sheets("Database")
  Set abcWS = Sheets("AP")
  With srcWS
    For Each brand In .Range("E12", .Range("E" & .Rows.Count).End(xlUp))
      LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
      desWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
      desWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
      desWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
      desWS.Range("G" & LastRow).Value = .Range("E" & brand.Row)
      desWS.Range("H" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
      desWS.Range("N" & LastRow).Resize(, 5).Value = Array(.Range("L37"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
      desWS.Range("S" & LastRow).Resize(, 1).Value = Array(.Range("F9"))
      desWS.Range("T" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
      desWS.Range("U" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
      desWS.Range("V" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
    Next brand
  
    LastRow = abcWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
    abcWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
    abcWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
    abcWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
    abcWS.Range("G" & LastRow).Resize(, 7).Value = Array(.Range("L36"), .Range("L37"), .Range("L38"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
    abcWS.Range("N" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
    abcWS.Range("O" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
    abcWS.Range("P" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
  End With
  Call ResetPurchaseReel
  Application.ScreenUpdating = True
End Sub

Sub ResetPurchaseReel()
  Dim srcWS As Worksheet
  Set srcWS = Sheets("Purchase Reel")
  With srcWS
    .Range("F5,F7,F9,J7,J9").Interior.Color = xlNone
    .Range("F5,F7,F9,J7,J9").Value = ""
    .Range("D12:K35").Interior.Color = xlNone
    .Range("D12:K35").Value = ""
    .Range("I37:I38,L37,H36").Interior.Color = xlNone
    .Range("I37:I38,L37,H36").Value = ""
  End With
End Sub

'Sales Module
Sub SaveNewDataSalesReel()
  Application.ScreenUpdating = False
  Dim sreWS As Worksheet, scrsWS As Worksheet, desWS As Worksheet
  Dim LastRow As Long, brand As Range
  
  Set scrsWS = Sheets("Sales Reel")
  Set desWS = Sheets("Database")
  Set sreWS = Sheets("AR")
  With scrsWS
    For Each brand In .Range("E12", .Range("E" & .Rows.Count).End(xlUp))
      LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
      desWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
      desWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
      desWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
      desWS.Range("G" & LastRow).Value = .Range("E" & brand.Row)
      desWS.Range("H" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
      desWS.Range("N" & LastRow).Resize(, 5).Value = Array(.Range("L37"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
      desWS.Range("S" & LastRow).Value = .Range("F9")
      desWS.Range("T" & LastRow).Value = .Range("H36")
      desWS.Range("U" & LastRow).Value = .Range("J5")
      desWS.Range("V" & LastRow).Value = .Range("F5")
    Next brand
    
    LastRow = sreWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
    sreWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
    sreWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
    sreWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
    sreWS.Range("G" & LastRow).Resize(, 7).Value = Array(.Range("L36"), .Range("L37"), .Range("L38"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
    sreWS.Range("N" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
    sreWS.Range("O" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
    sreWS.Range("P" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
  End With
  Call ResetSalesReel
  Application.ScreenUpdating = True
End Sub

Sub ResetSalesReel()
  Dim scrsWS As Worksheet
  Set scrsWS = Sheets("Sales Reel")
  With scrsWS
    .Range("F5,F7,F9,J7,J9").Interior.Color = xlNone
    .Range("F5,F7,F9,J7,J9").Value = ""
    .Range("D12:K35").Interior.Color = xlNone
    .Range("D12:K35").Value = ""
    .Range("H36,I37,I38,L37").Interior.Color = xlNone
    .Range("H36,I37,I38,L37").Value = ""
  End With
End Sub

Zubair · Apr 22, 2022

Thanks, AP & AR are perfect, but in the Database, the cartage figure is appearing with each line of Brand which is required only 1 time in column N.

DanteAmor · Apr 22, 2022

Zubair said:
the cartage figure is appearing with each line of Brand which is required only 1 time in column N

Sorry for that, I hadn't understood ?

I give you the updated code:

VBA Code:

'Purchase Module
Sub SaveNewDataPurchaseReel()
  Application.ScreenUpdating = True
  Dim LastRow As Long, brand As Range
  Dim abcWS As Worksheet, srcWS As Worksheet, desWS As Worksheet
  Dim cartage As Boolean
  
  Set srcWS = Sheets("Purchase Reel")
  Set desWS = Sheets("Database")
  Set abcWS = Sheets("AP")
  cartage = True
  With srcWS
    For Each brand In .Range("E12", .Range("E" & .Rows.Count).End(xlUp))
      LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
      desWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
      desWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
      desWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
      desWS.Range("G" & LastRow).Value = .Range("E" & brand.Row)
      desWS.Range("H" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
      If cartage Then
        desWS.Range("N" & LastRow).Resize(, 5).Value = Array(.Range("L37"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
      Else
        desWS.Range("O" & LastRow).Resize(, 4).Value = Array(.Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
      End If
      cartage = False
      desWS.Range("S" & LastRow).Resize(, 1).Value = Array(.Range("F9"))
      desWS.Range("T" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
      desWS.Range("U" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
      desWS.Range("V" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
    Next brand
  
    LastRow = abcWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
    abcWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
    abcWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
    abcWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
    abcWS.Range("G" & LastRow).Resize(, 7).Value = Array(.Range("L36"), .Range("L37"), .Range("L38"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
    abcWS.Range("N" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
    abcWS.Range("O" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
    abcWS.Range("P" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
  End With
  Call ResetPurchaseReel
  Application.ScreenUpdating = True
End Sub

Sub ResetPurchaseReel()
  Dim srcWS As Worksheet
  Set srcWS = Sheets("Purchase Reel")
  With srcWS
    .Range("F5,F7,F9,J7,J9").Interior.Color = xlNone
    .Range("F5,F7,F9,J7,J9").Value = ""
    .Range("D12:K35").Interior.Color = xlNone
    .Range("D12:K35").Value = ""
    .Range("I37:I38,L37,H36").Interior.Color = xlNone
    .Range("I37:I38,L37,H36").Value = ""
  End With
End Sub

'Sales Module
Sub SaveNewDataSalesReel()
  Application.ScreenUpdating = False
  Dim sreWS As Worksheet, scrsWS As Worksheet, desWS As Worksheet
  Dim LastRow As Long, brand As Range
  Dim cartage As Boolean
  
  Set scrsWS = Sheets("Sales Reel")
  Set desWS = Sheets("Database")
  Set sreWS = Sheets("AR")
  cartage = True
  With scrsWS
    For Each brand In .Range("E12", .Range("E" & .Rows.Count).End(xlUp))
      LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
      desWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
      desWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
      desWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
      desWS.Range("G" & LastRow).Value = .Range("E" & brand.Row)
      desWS.Range("H" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
      If cartage Then
        desWS.Range("N" & LastRow).Resize(, 5).Value = Array(.Range("L37"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
      Else
        desWS.Range("O" & LastRow).Resize(, 4).Value = Array(.Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
      End If
      cartage = False
      desWS.Range("S" & LastRow).Value = .Range("F9")
      desWS.Range("T" & LastRow).Value = .Range("H36")
      desWS.Range("U" & LastRow).Value = .Range("J5")
      desWS.Range("V" & LastRow).Value = .Range("F5")
    Next brand
    
    LastRow = sreWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
    sreWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
    sreWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
    sreWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
    sreWS.Range("G" & LastRow).Resize(, 7).Value = Array(.Range("L36"), .Range("L37"), .Range("L38"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
    sreWS.Range("N" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
    sreWS.Range("O" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
    sreWS.Range("P" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
  End With
  Call ResetSalesReel
  Application.ScreenUpdating = True
End Sub

Sub ResetSalesReel()
  Dim scrsWS As Worksheet
  Set scrsWS = Sheets("Sales Reel")
  With scrsWS
    .Range("F5,F7,F9,J7,J9").Interior.Color = xlNone
    .Range("F5,F7,F9,J7,J9").Value = ""
    .Range("D12:K35").Interior.Color = xlNone
    .Range("D12:K35").Value = ""
    .Range("H36,I37,I38,L37").Interior.Color = xlNone
    .Range("H36,I37,I38,L37").Value = ""
  End With
End Sub

Zubair · Apr 23, 2022

Excellent DanteAmor - It's perfectly working as I needed, Many thanks.

DanteAmor said:

Sorry for that, I hadn't understood ?

I give you the updated code:

VBA Code:

'Purchase Module
Sub SaveNewDataPurchaseReel()
  Application.ScreenUpdating = True
  Dim LastRow As Long, brand As Range
  Dim abcWS As Worksheet, srcWS As Worksheet, desWS As Worksheet
  Dim cartage As Boolean
 
  Set srcWS = Sheets("Purchase Reel")
  Set desWS = Sheets("Database")
  Set abcWS = Sheets("AP")
  cartage = True
  With srcWS
    For Each brand In .Range("E12", .Range("E" & .Rows.Count).End(xlUp))
      LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
      desWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
      desWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
      desWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
      desWS.Range("G" & LastRow).Value = .Range("E" & brand.Row)
      desWS.Range("H" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
      If cartage Then
        desWS.Range("N" & LastRow).Resize(, 5).Value = Array(.Range("L37"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
      Else
        desWS.Range("O" & LastRow).Resize(, 4).Value = Array(.Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
      End If
      cartage = False
      desWS.Range("S" & LastRow).Resize(, 1).Value = Array(.Range("F9"))
      desWS.Range("T" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
      desWS.Range("U" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
      desWS.Range("V" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
    Next brand
 
    LastRow = abcWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
    abcWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
    abcWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
    abcWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
    abcWS.Range("G" & LastRow).Resize(, 7).Value = Array(.Range("L36"), .Range("L37"), .Range("L38"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
    abcWS.Range("N" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
    abcWS.Range("O" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
    abcWS.Range("P" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
  End With
  Call ResetPurchaseReel
  Application.ScreenUpdating = True
End Sub

Sub ResetPurchaseReel()
  Dim srcWS As Worksheet
  Set srcWS = Sheets("Purchase Reel")
  With srcWS
    .Range("F5,F7,F9,J7,J9").Interior.Color = xlNone
    .Range("F5,F7,F9,J7,J9").Value = ""
    .Range("D12:K35").Interior.Color = xlNone
    .Range("D12:K35").Value = ""
    .Range("I37:I38,L37,H36").Interior.Color = xlNone
    .Range("I37:I38,L37,H36").Value = ""
  End With
End Sub

'Sales Module
Sub SaveNewDataSalesReel()
  Application.ScreenUpdating = False
  Dim sreWS As Worksheet, scrsWS As Worksheet, desWS As Worksheet
  Dim LastRow As Long, brand As Range
  Dim cartage As Boolean
 
  Set scrsWS = Sheets("Sales Reel")
  Set desWS = Sheets("Database")
  Set sreWS = Sheets("AR")
  cartage = True
  With scrsWS
    For Each brand In .Range("E12", .Range("E" & .Rows.Count).End(xlUp))
      LastRow = desWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
      desWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
      desWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
      desWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
      desWS.Range("G" & LastRow).Value = .Range("E" & brand.Row)
      desWS.Range("H" & LastRow).Resize(, 6).Value = .Range("G" & brand.Row).Resize(, 6).Value
      If cartage Then
        desWS.Range("N" & LastRow).Resize(, 5).Value = Array(.Range("L37"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
      Else
        desWS.Range("O" & LastRow).Resize(, 4).Value = Array(.Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
      End If
      cartage = False
      desWS.Range("S" & LastRow).Value = .Range("F9")
      desWS.Range("T" & LastRow).Value = .Range("H36")
      desWS.Range("U" & LastRow).Value = .Range("J5")
      desWS.Range("V" & LastRow).Value = .Range("F5")
    Next brand
   
    LastRow = sreWS.Range("E" & .Rows.Count).End(xlUp).Row + 1
    sreWS.Range("A" & LastRow).Resize(, 1).Value = Array(.Range("D12"))
    sreWS.Range("B" & LastRow).Resize(, 2).Value = Array(.Range("O1"), .Range("N1"))
    sreWS.Range("D" & LastRow).Resize(, 3).Value = Array(.Range("F7"), .Range("J7"), .Range("J9"))
    sreWS.Range("G" & LastRow).Resize(, 7).Value = Array(.Range("L36"), .Range("L37"), .Range("L38"), .Range("I37"), .Range("I38"), Application.UserName, [Text(Now(), "DD-MM-YYYY HH:MM:SS")])
    sreWS.Range("N" & LastRow).Resize(, 1).Value = Array(.Range("H36"))
    sreWS.Range("O" & LastRow).Resize(, 1).Value = Array(.Range("J5"))
    sreWS.Range("P" & LastRow).Resize(, 1).Value = Array(.Range("F5"))
  End With
  Call ResetSalesReel
  Application.ScreenUpdating = True
End Sub

Sub ResetSalesReel()
  Dim scrsWS As Worksheet
  Set scrsWS = Sheets("Sales Reel")
  With scrsWS
    .Range("F5,F7,F9,J7,J9").Interior.Color = xlNone
    .Range("F5,F7,F9,J7,J9").Value = ""
    .Range("D12:K35").Interior.Color = xlNone
    .Range("D12:K35").Value = ""
    .Range("H36,I37,I38,L37").Interior.Color = xlNone
    .Range("H36,I37,I38,L37").Value = ""
  End With
End Sub

DanteAmor · Apr 23, 2022

Im glad to help you, thanks for the feedback.

Zubair · Apr 25, 2022

DanteAmor said:
Im glad to help you, thanks for the feedback.

Hi DanteAmor,

Another little change is required as follows, please.

While performing sales entry the quantity & amount should appear as negative in the database column K & M.

Many thanks in advance.

Changes required in VBA code

Zubair

Active Member

Excel Facts

DanteAmor

Well-known Member

Zubair

Active Member

DanteAmor

Well-known Member

Zubair

Active Member

DanteAmor

Well-known Member

Zubair

Active Member

DanteAmor

Well-known Member

Zubair

Active Member

Similar threads

Forum statistics

Share this page

Changes required in VBA code

Active Member

Excel Facts

Well-known Member

Active Member

Well-known Member

Active Member

Well-known Member

Active Member

Well-known Member

Active Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock