# Deplete cell values based on a common reference

#### victoria2207

##### New Member
Good Afternoon, Please excuse me if something similar has already been posted. I am looking for a simple but robust way to deplete the value of a cell based on a common reference on another sheet. To clarify, Sheet 1 contains hundreds of rows of items in Column A with the current available value in Column B.

Sheet 2 to 34 have various different actions, each of which if carried out will deplete the available resources on Sheet 1, so:

Sheet 1:

 Reference Value available AA100 26 AA101 27 AA102 23 AA103 24 AA104 25 AA105 26 AA106 27 AA107 23 AA108 24 AA109 25 AA110 26 AA111 27 AA112 23

<tbody>
</tbody>

Sheet 2:

 Ref Item1 AA100 5 AA103 6 AA106 4 AA109 3 AA112 5

<tbody>
</tbody>

Essentially I want to reduce the 26 available of AA100 by 5 and AA103 by 6, AA104 by 4 etc. possibly using a button press?

I'm hoping there is already some VBA written or another simple way to achieve this.

TIA

Vic2207

### Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

#### MickG

##### MrExcel MVP
Try this:-
This code is for data on sheets1 & 2.
If you have similar data to sheet2 on the next 33 sheets and you want to incorporate them in the code let me Know !!
Code:
``````[COLOR="Navy"]Sub[/COLOR] MG09Mar02
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
[COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
.Item(Dn.Value) = Dn.Offset(, 1).Value
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
[COLOR="Navy"]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]If[/COLOR] .exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
Dn.Offset(, 1).Value = Dn.Offset(, 1).Value - .Item(Dn.Value)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]``````
Regards Mick

#### victoria2207

##### New Member
Thank you Mick - that worked a treat!

I don't need the code to reference every sheet thank you as I want an individual button push available for each action so I will just tailor the code and have individual macro's for each action.

Thanks again,

Vic2207

Try this:-
This code is for data on sheets1 & 2.
If you have similar data to sheet2 on the next 33 sheets and you want to incorporate them in the code let me Know !!
Code:
``````[COLOR=navy]Sub[/COLOR] MG09Mar02
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]With[/COLOR] Sheets("Sheet2")
[COLOR=navy]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
.Item(Dn.Value) = Dn.Offset(, 1).Value
[COLOR=navy]Next[/COLOR]
[COLOR=navy]With[/COLOR] Sheets("Sheet1")
[COLOR=navy]Set[/COLOR] Rng = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
[COLOR=navy]If[/COLOR] .exists(Dn.Value) [COLOR=navy]Then[/COLOR]
Dn.Offset(, 1).Value = Dn.Offset(, 1).Value - .Item(Dn.Value)
[COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]``````
Regards Mick

You're welcome

Replies
20
Views
170
Replies
1
Views
325
Replies
10
Views
452
Replies
3
Views
34
Replies
2
Views
469

1,109,336
Messages
5,528,101
Members
409,802
Latest member
joeino

### This Week's Hot Topics

• Change military grades into rank
Afternoon all Need help with formula that will change military rank (i.e. 1, 2, 3 into Amn, A1C, SrA). Running IF formula that does not work...
• VBA COUNTIF SOLUTION
Hi The following are the errors spread across the several columns from E to Q ie. 13 columns across several sheets with more than 500 rows per...
• INSERT ROW WITH SPECIFIS TEXT IN A COLUMN
Hi All! How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F. If I record the...