PDA

View Full Version : Add Remark in cloumn based on calculation/comparisons in one worksheet



fixer
05-16-2020, 01:51 PM
all files are located in a different path
vba macro will be placed in a seperate file
this macro
We have to look at S10 value, how much value S10 has
after knowing the S10 value, we will start adding the data in column Q till we reached the S10 value(or till we reach the value near to S10)But not greater than S10
example
in this sample file
S10 value is 1000
So we will add the value of column Q , So From Q2 to Q6 the total value is reached to 989.575 (close to S10 value 1000)
If We add the data ahead, then from Q2 TO Q7 the total value is 1061.53, Since it is greater than the value of S10 ,we cant consider Q2 to Q7
So we consider Q2 TO Q6(which is near to S10 , but not greater than S10 value)
Since we consider the Q2 to Q6, then we will put a remark in column J as 1(Since we consider the Q2 TO Q6 then we will put a remark in J2 to J6 as 1)

Column J is the result that i need when i ran the macro
So Plz have a look and do needful

DocAElstein
05-17-2020, 11:17 PM
Before

_____ Workbook: Book1.xlsm ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
L
M
N
O
P
Q
R
S
T

1LTP


2
63.3
1
60
1.055
1.055
54
156.97


3
56.65
6
60
0.94417
5.665
54
550.985


4
65.65
6
60
1.09417
6.565
54
59.085


5
73.05
1
60
1.2175
1.2175
54
165.745


6
63.1
6
60
1.05167
6.31
54
56.79


7
79.95
6
60
1.3325
7.995
54
71.955


8
27.55
1
60
0.45917
0.45917
54
24.795
8000


9
87.9
1
60
1.465
1.465
54
79.11
9000


10
81.65
6
51
1.60098
9.60588
54
86.4529Profit Amount
1000


11
67.9
1
60
1.13167
1.13167
54
61.11


12
Worksheet: Sheet1

Results After running macro

_____ Workbook: Book1.xlsm ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
L
M
N
O
P
Q
R
S
T

1LTP


2
63.3
1
1
60
1.055
1.055
54
156.97


3
56.65
1
6
60
0.94417
5.665
54
550.985


4
65.65
1
6
60
1.09417
6.565
54
59.085


5
73.05
1
1
60
1.2175
1.2175
54
165.745


6
63.1
1
6
60
1.05167
6.31
54
56.79


7
79.95
6
60
1.3325
7.995
54
71.955


8
27.55
1
60
0.45917
0.45917
54
24.795
8000


9
87.9
1
60
1.465
1.465
54
79.11
9000


10
81.65
6
51
1.60098
9.60588
54
86.4529Profit Amount
1000


11
67.9
1
60
1.13167
1.13167
54
61.11


12
Worksheet: Sheet1



' https://excelfox.com/forum/showthread.php/2489-Calculation-amp-Remark
'
Sub CalculationAndRemark()
Rem 1 Worksheets info
Dim Wb As Workbook
Set Wb = Workbooks("Book1.xlsm") ' change to suit
Dim Ws1 As Worksheet: Set Ws1 = Wb.Worksheets.Item(1)
Dim rngIn As Range: Set rngIn = Ws1.Range("A1:S11")
Dim arrIn() As Variant, arrOut() As Variant: Let arrIn() = rngIn.Value2
Dim S10Val As Double: Let S10Val = arrIn(10, 19)
Rem 2 Do it untill we are past 1000
Let arrOut() = arrIn()
Dim Cnt As Long, SomeTotal As Double
Let Cnt = 2: Let SomeTotal = arrIn(Cnt, 17)
Do
Let arrOut(Cnt, 10) = 1
Let Cnt = Cnt + 1
Let SomeTotal = SomeTotal + arrIn(Cnt, 17)
Loop While SomeTotal < S10Val
Rem 3 Output
Let rngIn.Value2 = arrOut()


End Sub

fixer
05-18-2020, 12:51 AM
I am getting error with This line Doc Sir plz have a look details has been attached

DocAElstein
05-18-2020, 01:10 AM
The last row is hard coded to 11 –
Ws1.Range("A1:S11")

You need to make the last row dynamic. You should know how to do that. ( http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466 Making Lr dynamic ( using rng.End(XlUp) for a single column. ) )
Try first yourself. If you have difficulties I will help again later

fixer
05-18-2020, 01:44 AM
I tried & No doubt i am facing difficulties in making the lr dynamic but I promise next time if u ask me to do so then No doubt u will get the answer from me Doc Sir

DocAElstein
05-18-2020, 02:06 AM
Before:
_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
L
M
N
O
P
Q

1LTP


2
63.3
1
60
1.055
1.055
54
56.97


3
56.65
6
60
0.94417
5.665
54
50.985


4
65.65
6
60
1.09417
6.565
54
59.085


5
73.05
1
60
1.2175
1.2175
54
65.745


6
63.1
6
60
1.05167
6.31
54
56.79


7
79.95
6
60
1.3325
7.995
54
71.955


8
27.55
1
60
0.45917
0.45917
54
24.795


9
87.9
1
60
1.465
1.465
54
79.11


10
81.65
6
51
1.60098
9.60588
54
86.4529


11
67.9
1
60
1.13167
1.13167
54
61.11


12
27
1
58
0.46552
0.46552
54
25.1379


13
18.4
6
42
0.4381
2.62857
54
23.6571


14
22.15
6
40
0.55375
3.3225
54
29.9025


15
72.05
1
55
1.31
1.31
54
70.74


16
94.35
1
60
1.5725
1.5725
54
84.915


17
62.5
6
60
1.04167
6.25
54
56.25


18
40.35
6
60
0.6725
4.035
54
36.315
Worksheet: Sheet1

After

_____ Workbook: Actual File.xlsx ( Using Excel 2007 32 bit )
Row\Col
H
I
J
K
L
M
N
O
P
Q

1LTP


2
63.3
1
1
60
1.055
1.055
54
56.97


3
56.65
1
6
60
0.94417
5.665
54
50.985


4
65.65
1
6
60
1.09417
6.565
54
59.085


5
73.05
1
1
60
1.2175
1.2175
54
65.745


6
63.1
1
6
60
1.05167
6.31
54
56.79


7
79.95
1
6
60
1.3325
7.995
54
71.955


8
27.55
1
1
60
0.45917
0.45917
54
24.795


9
87.9
1
1
60
1.465
1.465
54
79.11


10
81.65
1
6
51
1.60098
9.60588
54
86.4529


11
67.9
1
1
60
1.13167
1.13167
54
61.11


12
27
1
1
58
0.46552
0.46552
54
25.1379


13
18.4
1
6
42
0.4381
2.62857
54
23.6571


14
22.15
1
6
40
0.55375
3.3225
54
29.9025


15
72.05
1
1
55
1.31
1.31
54
70.74


16
94.35
1
1
60
1.5725
1.5725
54
84.915


17
62.5
1
6
60
1.04167
6.25
54
56.25


18
40.35
1
6
60
0.6725
4.035
54
36.315


19
287.65
6
60
4.79417
28.765
54
258.885
Worksheet: Sheet1


Sub CalculationAndRemark()
Rem 1 Worksheets info
Dim Wb As Workbook
Set Wb = Workbooks("Actual File.xlsx") ' Workbooks("Book1.xlsm") ' change to suit
Dim Ws1 As Worksheet: Set Ws1 = Wb.Worksheets.Item(1)
Dim Lr As Long
Let Lr = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim rngIn As Range: Set rngIn = Ws1.Range("A1:S" & Lr & "")
Dim arrIn() As Variant, arrOut() As Variant: Let arrIn() = rngIn.Value2
Dim S10Val As Double: Let S10Val = arrIn(10, 19)
Rem 2 Do it untill we are past 1000
Let arrOut() = arrIn()
Dim Cnt As Long, SomeTotal As Double
Let Cnt = 2: Let SomeTotal = arrIn(Cnt, 17)
Do
Let arrOut(Cnt, 10) = 1
Let Cnt = Cnt + 1
Let SomeTotal = SomeTotal + arrIn(Cnt, 17)
Loop While SomeTotal < S10Val
Rem 3 Output
Let rngIn.Value2 = arrOut()
End Sub

fixer
05-18-2020, 02:32 AM
Awesome Doc Sir, Thnx Alot for helping me in Solving the same
Next time If there will be Any Lr issue then i will take care of that