VBA Code to apply in each monthly worksheet

- - Latest reply: ac3mark
Posts
12539
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
July 12, 2019
- May 31, 2019 at 12:30 PM
Hi,

I have a monthly creditor file (create new tab for each month when required) and want to calculate the amount outstanding each month, which is represented by those cells that have no shading.
I need the vba code to apply to each sheet (across the workbook) so that it will calculate this for me in each monthly tab - the below vba code works for one month only, but errors out when I try to replicate it in another month.

Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As Boolean)
Dim rCell As Range
Dim lCol As Long
Dim vResult
lCol = rColor.Interior.ColorIndex
If SUM = True Then
For Each rCell In rRange
If rCell.Interior.ColorIndex = lCol Then
vResult = WorksheetFunction.SUM(rCell, vResult)
End If
Next rCell
Else
For Each rCell In rRange
If rCell.Interior.ColorIndex = lCol Then
vResult = 1 + vResult
End If
Next rCell
End If
ColorFunction = vResult
End Function

Unfortunately I'm no expert on vba, but with trial and error and someone's assistance they can help me achieve what I need.

Note, I only create a tab for each month when required - maybe they all need to be created as part of the initial template and is it important that the row and column references are the same in each tab when performing the calculation (=colorfunction(A4,range,True).

Many thanks in advance.
Michael
See more 

6 replies

Posts
12539
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
July 12, 2019
1138
0
Thank you
Well the problem is, you do not define the worksheet. Define a variable of sheet and pass that as you do with other parameters in the COLORFUNCTION function.

Then after you can pass that without error, you add in a loop for each sheet.

The syntax for counting sheets is as follows:

tabcount=Thisworkbook.worksheets.count

Then you loop to it:
For tab=1 to tabcount

Then you can activate any sheet (tab) by the index number, as in:

Thisworkbook.worksheets (tab)

This is a wireframe only. I will not construct a complete working code, as my goal is to teach you how, not just cut and paste.


Micwhsct
Posts
4
Registration date
Wednesday May 29, 2019
Status
Member
Last seen
May 31, 2019
-
Thankyou for your prompt response ac3mark,

Unfortunately, I may have overstated/implied my vba ability.

I think I understand what it is that the vba coding requires to work, but I am not knowledgeable enough to code this and know at which point to insert into the coding that already exists (which I also got from the internet).

I would really appreciate if you could provide the coding and then and I can step through it to see how it works and the manner in which it is constructed.

And absolutely, I do want to learn it, but lets not walk before I can crawl :-)

Merci

Michael
ac3mark
Posts
12539
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
July 12, 2019
1138 -
I will attempt to out together a complete model after work today.
ac3mark
Posts
12539
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
July 12, 2019
1138 -
There are dudes that are way better at codeing Excel then me, that ussually drop in later in the week. Please understand, if I dont get back to this, someone will assist.
Micwhsct
Posts
4
Registration date
Wednesday May 29, 2019
Status
Member
Last seen
May 31, 2019
-
Thanks for your directions above ac3mark.

Based on this I introduced the following code at the start of my vba, again got on the internet, and having tested it in my file it seems to be working okay. Not sure if it covers everything you were suggesting.

Sub kl()

Dim wb As Workbook
Dim ws As Worksheet

Set wb = ActiveWorkbook
'be aware as this might produce an error, if Shet "name" does not exist
Set ws = wb.Sheets("name")
' if wb is other than the active workbook
wb.Activate
ws.Select

End Sub

Thanks again for your guidance.
Micwhsct
Posts
4
Registration date
Wednesday May 29, 2019
Status
Member
Last seen
May 31, 2019
-
Just an update, when I create a new month the vba does not error out, but does not count the blank cells unless I reformat them as clear.

Can anyone advise what may be missing from my vba coding to prevent having to do this and manually re-apply the formula monthly.

Thankyou
Respond to ac3mark
Posts
12539
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
July 12, 2019
1138
0
Thank you
Ok, I found where you cut that function from, and deployed it into my own workbook. I deployed it in a new module, called Module1. I added in five new sheets. Selected the last sheet and set up a yellow cell in A1. Placed a value of five in cell A2, and colored the cell the same yellow. Then in cell D1, placed the following =ColorFunction (A1, A2:G9, true) and it returned the five. If I push false, it counts the two yellow cells, as it should. So the function will work on added sheets as written. If you do not get a valid entry on a newly created sheet, then check to make certain you have not deployed the function on a worksheet, but in a common module to all sheets.


please take note of the tab in below picture




ac3mark
Posts
12539
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
July 12, 2019
1138 -
Note tab
Respond to ac3mark
Posts
12539
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
July 12, 2019
1138
0
Thank you
Ok, lets look at it like this, the yellow should only be there for HUMANS BENEFIT. So what we need is a simple calculation of outstanding accounts. The calculations should be first, then the colors. The code that you have used, looks at the colors first for calculations.

It is very simple if we look at the value calculations first, then as a result of those, they get a color feedback for your workers.

Respond to ac3mark
Posts
12539
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
July 12, 2019
1138
0
Thank you
I will simplify what I have in code and post back. Then we can do the cell coloring after we get the calculatiosn running on every sheet.
Respond to ac3mark
Posts
12539
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
July 12, 2019
1138
0
Thank you
Stop and read this entire post, as if you just cut and paste, it will wreck your current sheet, altering cells! DEPLOY AT YOUR RISK, OR DEPLOY on A COPY!


Requirements:
In the function CalcRow, make certain that the pCell(payment cell) is the correct Column.
In the function CalcRow, make certain that the bCell(balance cell) is the correct Column.
In the function CalcRow, make certain that the cCell(calculated cell) is the correct Column.

The below code starts by running StartCalc.

StartCalc loads a vriable called SheetNumMax with a call to the function counttabs. Count tabs counts and returns the number of sheets in the workbook.
StartCalc then loops through each sheet, and calls a function named FindLastRow, to see how many rows there are on the current sheet.
FindLastRow initializes a variable of rownum, and we loop though each row with the variable "t".
During the loop, we call CalcRow, to perform the claculations of Outstanding balances.
CalcRow also calls for checking the value of cCell, by calling CheckVal and passing cCell.
CheckVal looks at the value of cCell, and if it is greater than 0, it colors the cell yellow.

Function StartCalc()
Dim SheetNumMax
Dim rownum
SheetNumMax = counttabs
For st = 1 To SheetNumMax
ThisWorkbook.Worksheets(st).Activate
rownum = FindLastRow(st)
For t = 2 To rownum
CalcRow (t)
Next
Next
End Function

Function counttabs()
Dim numTabs
numTabs = ThisWorkbook.Worksheets.Count
counttabs = numTabs
End Function


Function FindLastRow(OnWhatsheet)
FindLastRow = Cells(ThisWorkbook.Worksheets(OnWhatsheet).Rows.Count, 1).End(xlUp).Row

End Function


Function CalcRow(whatrow)
Dim bCell, pCell, cCell
pCell = "A" & whatrow
bCell = "B" & whatrow
cCell = "C" & whatrow
theval = Range(bCell).Value - Range(pCell).Value
MsgBox (theval) 'remark out this line if you do not wish to have feedback of totals!
Range(cCell).Value = theval
CheckVal (cCell)
End Function


Sub CheckVal(whatcell)
If Range(whatcell).Value > 0 Then
Range(whatcell).Interior.ColorIndex = 6 'yellow
End If
End Sub




Respond to ac3mark
Posts
4
Registration date
Wednesday May 29, 2019
Status
Member
Last seen
May 31, 2019
0
Thank you
Thank you ac3mark,

Unfortunately with other priorities I will not get the opportunity to review until next week, but thanks again.
ac3mark
Posts
12539
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
July 12, 2019
1138 -
No problems. Have fun!
Respond to Micwhsct