PDA

View Full Version : [SOLVED] Creating a single Table with different formulas Excel VBA



AaliiyahN82
04-24-2020, 08:38 PM
Hi everyone! I just signed up today to ask for help from y'all. I am a newbie when it comes to VBA. I am literally new like I started just yesterday, y'know. Basically I am trying to create a single table with multiple formulas in it. I can't manually put the formulas because the list in the database sheet is dynamic.

What I am trying to do is this:

26435

Categories can be found on the database sheet. Number format of sub categories depend on their respective formats which are indicated on the other sheets.

This is what I have so far: I got this idea from one of the threads here:


Sub testing()

Set Rng = Sheets("Database").Range("A1").CurrentRegion
Set Rng = Intersect(Rng, Rng.Offset(1))
MCategory = ""


For Each cll In Rng.Cells
MCategory = cll.Value

Set Destn = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1)
With Destn
.Value = cll.Offset(, 1).Value
End With
Next cll
End Sub


I am only able to do the categories part, but I don't know how to do the formulas since they differ depending on whether it's for monthly/weekly and Main Category/Sub Category.

I am using Windows 10 and Office 365 if that's something you need to know.

Attached herewith is my sample file.

Your gracious help is highly appreciated. Thank you so much :)

PS: I also posted here at 1:51AM today: https://www.mrexcel.com/board/threads/creating-a-single-table-with-different-formulas-excel-vba.1131940/

AaliiyahN82
04-24-2020, 11:45 PM
Hmm any help is super appreciated. :)

paulked
04-25-2020, 03:54 AM
Hi and welcome to the forum.

I think you need to explain yourself better... or at least say what you want with an example!

AaliiyahN82
04-25-2020, 04:10 AM
HI Paul thank you for replying. :)

I have a sheet called Database. It contains all information about categories and sub categories like their target numbers per sub category, as well as the format of each target (like if they are in decimal or percentage). This list changes a lot.

In my Table sheet, I need to list each category with their sub categories below them. Then I need to compute their values based on the weekly and monthly sheet. However, the main category rows have different formulae versus the sub category rows. They also differ on the number format.

AaliiyahN82
04-26-2020, 01:10 AM
Hi everyone! Maybe another one also has an idea like paulked? :)

Any help is truly appreciated! Thank you! :)

SamT
04-26-2020, 06:23 AM
Some suggested Procedures (examples only)


Sub CellFormat (cll As Range, FormatType As String)
If LCase(FormatType) = "percentage" then Cll.Numberforemat = ...
If LCase(FormatType) = "decimal" then Cll.Numberforemat = ...
If LCase(FormatType) = "bold" then Cll.Font = ...
'Room to add more conditions if/when needed
End Sub

AaliiyahN82
04-26-2020, 07:05 AM
Hi Sam thanks for responding :)
I am actually more concerned about the formulae part because they are a lot and they differ for categories and sub categories and whether they are for weekly or monthly --- and they are all in a single table.

I was thinking if this is possible using calculated fields in a Pivot? Is it?

SamT
04-26-2020, 10:57 AM
Excel Cell Fomulas are Strings in VBA.
Precede the formula with an apostrophe in the cell and it becomes a String an not a Formula '=SumIf(blahblah). Put those in Column B and in Column A place the names/uses of the formula Cat1SubCat1Wkly then you can use the same method as above.

AaliiyahN82
04-26-2020, 01:27 PM
Hi Sam. My apologies, that got me confused ��
I am literally new to all this, I literally started like a day before posting here so I really have no idea about what you're talking about ��

Would you mind giving me a rough example?
Does this require loops? Or something?

SamT
04-27-2020, 12:41 AM
https://analystcave.com/top-3-best-excel-vba-books-recommended-vba-books/

https://www.amazon.com/Best-Sellers-Books-Microsoft-VBA/zgbs/books/4047

https://www.wallstreetmojo.com/vba-books/

What I strongly recommend for VBA Developers is to use Office XP or 2003 because they have built-in help files linked to every VBA Keyword. VBA is still basically the same as it was when created for Excel 5

https://www.ebay.com/itm/MICROSOFT-OFFICE-BASIC-EDITION-2003-OEM-FOR-WINDOWS-WITH-PRODUCT-KEY/153909289793?hash=item23d5b56341:g:DdYAAOSwoxVdZAQ3

https://www.ebay.com/p/127902608?iid=303407744277

https://www.ebay.com/p/128261044?iid=303373874962

https://www.ebay.com/p/127813290?iid=233561961107

snb
04-27-2020, 01:27 AM
If you create a pivottable based on the data in sheet weekly, no VBA is needed.

jazz2409
04-28-2020, 08:59 PM
I understand that calculated fields only apply to columns in a Pivot Table, but is there a way to do as well for rows? Like the main category has a different formula then the sub category also has a different formula. However the sub categories are placed under each main category. They are not on 2 separate columns

Attached is my sample workbook.

I have this formula on Table Sheet:


=IFS(

AND(LEFT(F$6,3)="MTD",(COUNTIF('Sheet2'!$W:$W,Table!$B8))=1), IFERROR(COUNTIFS(Monthly!$L:$L,"P",Monthly!$J:$J,Table!F$7,Monthly!$A:$A,Table!$B8)/SUMIFS(Monthly!$M:$M,Monthly!$J:$J,Table!F$7,Monthly!$A:$A,Table!$B8),"-"),


AND(LEFT(F$6,3)="MTD",(COUNTIF('Sheet2'!$W:$W,Table!$B8))=0,$D8="Percentage"), TEXT(SUMIFS(Monthly!$K:$K,Monthly!$J:$J,Table!F$7,Monthly!$A:$A,Table!$B$8, Monthly!$D:$D,Table!$B8),"0.00%"),
AND(LEFT(F$6,3)="MTD",(COUNTIF('Sheet2'!$W:$W,Table!$B8))=0,$D8="Decimal"), TEXT(SUMIFS(Monthly!$K:$K,Monthly!$J:$J,Table!F$7,Monthly!$A:$A,Table!$B$8, Monthly!$D:$D,Table!$B8),"0.00 "),


AND(LEFT(F$6,3)="WEE",(COUNTIF('Sheet2'!$W:$W,Table!$B8))=1), IFERROR(COUNTIFS(Weekly!$L:$L,"P",Weekly!$J:$J,Table!F$7,Weekly!$A:$A,Table!$B8)/SUMIFS(Weekly!$M:$M,Weekly!$J:$J,Table!F$7,Weekly!$A:$A,Table!$B8),"-"),


AND(LEFT(F$6,3)="WEE",(COUNTIF('Sheet2'!$W:$W,Table!$B8))=0,$D8="Percentage"), TEXT(SUMIFS(Weekly!$K:$K,Weekly!$J:$J,Table!F$7,Weekly!$A:$A,Table!$B$8,Wee kly!$D:$D,Table!$B8),"0.00%"),
AND(LEFT(F$6,3)="WEE",(COUNTIF('Sheet2'!$W:$W,Table!$B8))=0,$D8="Decimal"), TEXT(SUMIFS(Weekly!$K:$K,Weekly!$J:$J,Table!F$7,Weekly!$A:$A,Table!$B$8,Wee kly!$D:$D,Table!$B8),"0.00 ")
)

It works only for the first main category and sub categories but if I move on to the new main category it fails already.

AaliiyahN82
04-29-2020, 02:45 AM
Hello, my project partner Jazz Homer posted a new thread regarding this. I think she was able to explain this better than I did.

AaliiyahN82
04-29-2020, 02:46 AM
If you create a pivottable based on the data in sheet weekly, no VBA is needed.

The thing about Pivots is that while we can create calculated fields, it will be a stand alone field instead of being values using existing data as columns

AaliiyahN82
04-29-2020, 02:54 AM
Hello, if there's anyone who can help me and my project partner Jazz Homer. Please. Thank you.

I also posted Jazz's post here: https://superuser.com/questions/1546859/calculated-fields-pivot-tables

SamT
04-29-2020, 06:36 AM
I think your data structure is completely FuBar and needs to be completely rebuilt from scratch.

I looks to me as if you are trying to save (no cost) Real Estate by consolidating as much information for Users as possible on as few Excel Worksheets as possible.

I have attached a sample of a well designed, at least IMO, data Table. Note that the Workbook Name contains the Year it is to be used in. I did break one rule of data tables in that I included both Monthly and Weekly data tables on one sheet.

jazz2409
04-29-2020, 06:45 AM
Sorry what is FuBar?
This is what they gave us to use.. But I am willing to change it if it's going to make things better (which I think it will)

Actually yes it's for a real estate company 🤣

paulked
04-29-2020, 07:26 AM
I'd Google Fubar rather than ask for an answer here :wink: :doh:

jazz2409
04-29-2020, 08:39 AM
Sorry but is there any chance that I can still continue with my sample workbook? I already asked if they are willing to change the view but they are not :(

They really want the sub categories be under each main category and both have different formulae like the one I indicated above :( Also they want both MTD and 8-week view just like that :(

Initially they just wanted to include main categories in that table but suddenly they wanted the sub categories be included under each main category and then look up the value from the two sheets :banghead::banghead:

jazz2409
04-29-2020, 08:43 AM
I'd Google Fubar rather than ask for an answer here :wink: :doh:

I just did.. It's my first time to encounter such term :rofl:

SamT
04-29-2020, 10:51 AM
Sorry but is there any chance that I can still continue with my sample workbook? I
You can, but I'm not going to try to unravel that washtub of spaghetti. And you can tell your management that I said they are asking for a short road to hell.

By the way, I am going to merge AaliiyahN82 (http://www.vbaexpress.com/forum/member.php?78052-AaliiyahN82)'s thread relating to this issue into this thread.

Bob Phillips
04-29-2020, 04:33 PM
Is this any use for you?


Public Sub CategoryAnalysis()
Const FORMULA_CATEGORY As String = _
"=IFERROR(COUNTIFS(<period>!C10,""P"",<period>!C8,Table!R6C,<period>!C1,Table!RC1)/SUMIFS(<period>!C11,<period>!C8,Table!R6C,<period>!C1,Table!RC1),""-"")"
Const FORMULA_SUB_CATEGORY As String = _
"=SUMIFS(<period>!C9,<period>!C8,Table!R6C,<period>!C4,Table!RC1)"
Dim database As Worksheet
Dim level As String
Dim nextrow As Long
Dim lastrow As Long
Dim i As Long


Set database = Worksheets("Database")
With Worksheets("Table")

SetupHeadings
nextrow = 7

lastrow = database.Cells(Rows.Count, "A").End(xlUp).Row
level = vbNullString
For i = 2 To lastrow

If database.Cells(i, "A").Value <> level Then

level = database.Cells(i, "A").Value
.Cells(nextrow, "A").Value = level
.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")
.Cells(nextrow, "C").Resize(1, 10).NumberFormat = "0%"
.Cells(nextrow, "C").Resize(1, 10).Font.Bold = True
.Cells(nextrow, "C").Resize(1, 10).HorizontalAlignment = xlCenter

nextrow = nextrow + 1
End If

.Cells(nextrow, "A").Value = database.Cells(i, "D").Value
.Cells(nextrow, "A").Font.Italic = True
.Cells(nextrow, "A").HorizontalAlignment = xlLeft
.Cells(nextrow, "A").IndentLevel = 1
.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly")
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly")
.Cells(nextrow, "C").Resize(1, 10).HorizontalAlignment = xlCenter
Select Case database.Cells(i, "H").Value

Case "Percentage"

.Cells(nextrow, "C").Resize(1, 10).NumberFormat = "0%"

Case "Decimal"

.Cells(nextrow, "C").Resize(1, 10).NumberFormat = "#0.000"
End Select

nextrow = nextrow + 1
Next i
End With
End Sub

Private Sub SetupHeadings()

With Worksheets("Table")

.Range("A5:L5").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", "WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
.Range("C5:D5").Interior.Color = RGB(84, 130, 53)
.Range("E5:L5").Interior.Color = RGB(142, 169, 219)
.Range("A5:L5").Font.Color = vbWhite
.Range("A6:B6").Value = Array("CATEGORY", "TARGET")
.Range("A6:D6").Interior.Color = RGB(198, 224, 180)
.Range("E6:L6").Interior.Color = RGB(180, 198, 231)
.Range("C6").FormulaArray = "=MAX(IF(Monthly!C12=Table!R1C2,Monthly!C8))"
.Range("D6").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
.Range("E6").FormulaR1C1 = "=MAX(Weekly!C8)"
.Range("C6:L6").NumberFormat = "dd-mmm"
.Range("F6:L6").FormulaR1C1 = "=RC[-1]-7"
.Range("A5:L6").HorizontalAlignment = xlCenter
.Range("A5:L6").Font.Bold = True
End With
End Sub

jazz2409
04-29-2020, 07:40 PM
Is this any use for you?


Public Sub CategoryAnalysis()
Const FORMULA_CATEGORY As String = _
"=IFERROR(COUNTIFS(<period>!C10,""P"",<period>!C8,Table!R6C,<period>!C1,Table!RC1)/SUMIFS(<period>!C11,<period>!C8,Table!R6C,<period>!C1,Table!RC1),""-"")"
Const FORMULA_SUB_CATEGORY As String = _
"=SUMIFS(<period>!C9,<period>!C8,Table!R6C,<period>!C4,Table!RC1)"
Dim database As Worksheet
Dim level As String
Dim nextrow As Long
Dim lastrow As Long
Dim i As Long


Set database = Worksheets("Database")
With Worksheets("Table")

SetupHeadings
nextrow = 7

lastrow = database.Cells(Rows.Count, "A").End(xlUp).Row
level = vbNullString
For i = 2 To lastrow

If database.Cells(i, "A").Value <> level Then

level = database.Cells(i, "A").Value
.Cells(nextrow, "A").Value = level
.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")
.Cells(nextrow, "C").Resize(1, 10).NumberFormat = "0%"
.Cells(nextrow, "C").Resize(1, 10).Font.Bold = True
.Cells(nextrow, "C").Resize(1, 10).HorizontalAlignment = xlCenter

nextrow = nextrow + 1
End If

.Cells(nextrow, "A").Value = database.Cells(i, "D").Value
.Cells(nextrow, "A").Font.Italic = True
.Cells(nextrow, "A").HorizontalAlignment = xlLeft
.Cells(nextrow, "A").IndentLevel = 1
.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly")
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly")
.Cells(nextrow, "C").Resize(1, 10).HorizontalAlignment = xlCenter
Select Case database.Cells(i, "H").Value

Case "Percentage"

.Cells(nextrow, "C").Resize(1, 10).NumberFormat = "0%"

Case "Decimal"

.Cells(nextrow, "C").Resize(1, 10).NumberFormat = "#0.000"
End Select

nextrow = nextrow + 1
Next i
End With
End Sub

Private Sub SetupHeadings()

With Worksheets("Table")

.Range("A5:L5").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", "WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
.Range("C5:D5").Interior.Color = RGB(84, 130, 53)
.Range("E5:L5").Interior.Color = RGB(142, 169, 219)
.Range("A5:L5").Font.Color = vbWhite
.Range("A6:B6").Value = Array("CATEGORY", "TARGET")
.Range("A6:D6").Interior.Color = RGB(198, 224, 180)
.Range("E6:L6").Interior.Color = RGB(180, 198, 231)
.Range("C6").FormulaArray = "=MAX(IF(Monthly!C12=Table!R1C2,Monthly!C8))"
.Range("D6").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
.Range("E6").FormulaR1C1 = "=MAX(Weekly!C8)"
.Range("C6:L6").NumberFormat = "dd-mmm"
.Range("F6:L6").FormulaR1C1 = "=RC[-1]-7"
.Range("A5:L6").HorizontalAlignment = xlCenter
.Range("A5:L6").Font.Bold = True
End With
End Sub


hello, the highlighted has to be taken into consideration for the ones that are in italics. Basically the ones that in italics already have values that are on the weekly and monthly sheets, we just need to look them up from those sheets and then put them into the table.

26499

jazz2409
04-29-2020, 07:45 PM
You can, but I'm not going to try to unravel that washtub of spaghetti. And you can tell your management that I said they are asking for a short road to hell.

By the way, I am going to merge AaliiyahN82 (http://www.vbaexpress.com/forum/member.php?78052-AaliiyahN82)'s thread relating to this issue into this thread.

Hahaha I wish I could just tell them to "gfy" without losing my job. :rofl:

SamT
04-29-2020, 07:52 PM
I got friends down that way :devil2: :eek:
:cool:

Take it home and in your own time do it the right way, Then at work just treat their workbook as a Report and use your book to fill in the blanks once a week.
:beerchug:

Seriously, you could create the "Right way" on xlVeryHidden sheets and then fill in the blanks on their Report sheets. Report sheets do belong to those who need the Reports, It's just our job to fill in the blanks on their Reports. I don't usually even think about Reports until I have at least a rough draft of the Data Base sheets, but you might have to work bass ackwards.

jazz2409
04-29-2020, 08:32 PM
I got friends down that way :devil2: :eek:
:cool:

Take it home and in your own time do it the right way, Then at work just treat their workbook as a Report and use your book to fill in the blanks once a week.
:beerchug:

Seriously, you could create the "Right way" on xlVeryHidden sheets and then fill in the blanks on their Report sheets. Report sheets do belong to those who need the Reports, It's just our job to fill in the blanks on their Reports. I don't usually even think about Reports until I have at least a rough draft of the Data Base sheets, but you might have to work bass ackwards.

I am taking your advice, I will follow the workbook you attached. Maybe I can show it to them and make them realize you're right :yes

For now I just really need to once and for all solve this thing right here so I'll have something to present to them tomorrow morning.

Bob Phillips
04-30-2020, 01:06 AM
hello, the highlighted has to be taken into consideration for the ones that are in italics. Basically the ones that in italics already have values that are on the weekly and monthly sheets, we just need to look them up from those sheets and then put them into the table.

26499

Isn't that what my code does?

Bob Phillips
04-30-2020, 01:57 AM
What I mean is that Category 1a, Category 1b are subs of Category 1, so by testing the sub-category you are automatically testing the category. No need to include both.

jazz2409
04-30-2020, 03:12 AM
What I mean is that Category 1a, Category 1b are subs of Category 1, so by testing the sub-category you are automatically testing the category. No need to include both.


Hello, yes it actually does do that.. It's just that I forgot to mention that some sub categories repeat for other main categories...

Bob Phillips
04-30-2020, 03:38 AM
Easily added in.


Public Sub CategoryAnalysis()
Const FORMULA_CATEGORY As String = _
"=IFERROR(COUNTIFS(<period>!C10,""P"",<period>!C8,Table!R6C,<period>!C1,Table!RC1)" & _
"/SUMIFS(<period>!C11,<period>!C8,Table!R6C,<period>!C1,Table!RC1),""-"")"
Const FORMULA_SUB_CATEGORY As String = _
"=SUMIFS(<period>!C9,<period>!C1,""<level>"",<period>!C8,Table!R6C,<period>!C4,Table!RC1)"
Dim database As Worksheet
Dim level As String
Dim nextrow As Long, lastrow As Long
Dim i As Long

Application.ScreenUpdating = False

Set database = Worksheets("Database")
With Worksheets("Table")

SetupHeadings
nextrow = 7

lastrow = database.Cells(Rows.Count, "A").End(xlUp).Row
level = vbNullString
For i = 2 To lastrow

'setup category row text, formulas and formats
If database.Cells(i, "A").Value <> level Then

level = database.Cells(i, "A").Value
With .Cells(nextrow, "A")

.Value = level
.Font.Italic = False
.HorizontalAlignment = xlLeft
.IndentLevel = 0
End With

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")

With .Cells(nextrow, "C").Resize(1, 10)

.NumberFormat = "0%"
.Font.Size = 10
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With

nextrow = nextrow + 1
End If

'setup sub-category row text, formulas and formats
With .Cells(nextrow, "A")

.Value = database.Cells(i, "D").Value
.Font.Italic = True
.HorizontalAlignment = xlLeft
.IndentLevel = 1
End With

.Cells(nextrow, "B").Value = database.Cells(i, "F").Text

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly"), "<level>", level)
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly"), "<level>", level)


With .Cells(nextrow, "C").Resize(1, 10)
Select Case database.Cells(i, "H").Value

Case "Percentage": .NumberFormat = "0%"
Case "Decimal": .NumberFormat = "#0.000"
End Select
.Font.Size = 8
.Font.Bold = False
.HorizontalAlignment = xlCenter
End With

nextrow = nextrow + 1
Next i
End With

Application.ScreenUpdating = True
End Sub

Private Sub SetupHeadings()

With Worksheets("Table")

.Range("A5:L5").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", "WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
.Range("C5:D5").Interior.Color = RGB(84, 130, 53)
.Range("E5:L5").Interior.Color = RGB(142, 169, 219)
.Range("A5:L5").Font.Color = vbWhite
.Range("A6:B6").Value = Array("CATEGORY", "TARGET")
.Range("A6:D6").Interior.Color = RGB(198, 224, 180)
.Range("E6:L6").Interior.Color = RGB(180, 198, 231)
.Range("C6").FormulaArray = "=MAX(IF(Monthly!C12=Table!R1C2,Monthly!C8))"
.Range("D6").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
.Range("E6").FormulaR1C1 = "=MAX(Weekly!C8)"
.Range("C6:L6").NumberFormat = "dd-mmm"
.Range("F6:L6").FormulaR1C1 = "=RC[-1]-7"
.Range("A5:L6").HorizontalAlignment = xlCenter
.Range("A5:L6").Font.Bold = True
End With
End Sub

jazz2409
04-30-2020, 04:19 AM
THANK YOU SO MUCH! :crying:
We'll have something to present in our zoom meeting later because of all of you here :crying:

:bow::bow::bow::bow::bow:

jazz2409
04-30-2020, 04:20 AM
I can't tag the thread as solved... Why?

Bob Phillips
04-30-2020, 04:43 AM
It is in the Thread Tools link towards the top of the page. I have done it for you this time.

jazz2409
04-30-2020, 08:51 AM
It is in the Thread Tools link towards the top of the page. I have done it for you this time.

Hello, Sorry how do I add this line:


With .Cells(nextrow, "G").Resize(1, 8)
Select Case Worksheets("Weekly").Cells(i, "L").Value

Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
.Font.Size = 8
.Font.Bold = False
.HorizontalAlignment = xlCenter
End With


It's for if the sub category says P on the weekly (for the weekly cells of sub categories)/monthly (for the monthly cells of sub categories)sheets, the numbers will be color green. And then if it's F, the numbers will be red. Just for sub categories.

I tried adding it at the end after the select case statement for decimal/percentage. It worked while it was running but once it was done it went back to being black

Bob Phillips
04-30-2020, 09:03 AM
Why Weekly sheet? Why column G? Why 8 columns?

jazz2409
04-30-2020, 09:11 AM
Why Weekly sheet? Why column G? Why 8 columns?

I was thinking I'll have a different set of select case statements for weekly and monthly sheets :think:
Sorry it's supposedly column E. Based on the table the weekly numbers will be from E:L - that's why it's 8, as to what I understood it's resize to 8 columns?
And then the one for monthly will be columns C : D and then resize(1,2)?

Bob Phillips
04-30-2020, 09:34 AM
Column E makes more sense. Not sure which column in Monthly, I left it at L, you might need to change.


Public Sub CategoryAnalysis()
Const FORMULA_CATEGORY As String = _
"=IFERROR(COUNTIFS(<period>!C10,""P"",<period>!C8,Table!R6C,<period>!C1,Table!RC1)" & _
"/SUMIFS(<period>!C11,<period>!C8,Table!R6C,<period>!C1,Table!RC1),""-"")"
Const FORMULA_SUB_CATEGORY As String = _
"=SUMIFS(<period>!C9,<period>!C1,""<level>"",<period>!C8,Table!R6C,<period>!C4,Table!RC1)"
Dim database As Worksheet
Dim level As String
Dim nextrow As Long, lastrow As Long
Dim i As Long

Application.ScreenUpdating = False

Set database = Worksheets("Database")
With Worksheets("Table")

SetupHeadings
nextrow = 7

lastrow = database.Cells(Rows.Count, "A").End(xlUp).Row
level = vbNullString
For i = 2 To lastrow

'setup category row text, formulas and formats
If database.Cells(i, "A").Value <> level Then

level = database.Cells(i, "A").Value
With .Cells(nextrow, "A")

.Value = level
.Font.Italic = False
.HorizontalAlignment = xlLeft
.IndentLevel = 0
End With

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")

With .Cells(nextrow, "C").Resize(1, 10)

.NumberFormat = "0%"
.Font.Size = 10
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With

nextrow = nextrow + 1
End If

'setup sub-category row text, formulas and formats
With .Cells(nextrow, "A")

.Value = database.Cells(i, "D").Value
.Font.Italic = True
.HorizontalAlignment = xlLeft
.IndentLevel = 1
End With

.Cells(nextrow, "B").Value = database.Cells(i, "F").Text

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly"), "<level>", level)
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly"), "<level>", level)

With .Cells(nextrow, "C").Resize(1, 2)

Select Case Worksheets("Monthly").Cells(i, "L").Value

Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
End With

With .Cells(nextrow, "C").Resize(1, 10)

Select Case database.Cells(i, "H").Value

Case "Percentage": .NumberFormat = "0%"
Case "Decimal": .NumberFormat = "#0.000"
End Select
.Font.Size = 8
.Font.Bold = False
.HorizontalAlignment = xlCenter
End With

With .Cells(nextrow, "E").Resize(1, 8)

Select Case Worksheets("Weekly").Cells(i, "L").Value

Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
End With

nextrow = nextrow + 1
Next i
End With

Application.ScreenUpdating = True
End Sub

jazz2409
04-30-2020, 10:18 AM
Didn't work... Well yes it did work but not quite. It only colors the entire row and nor per item :(

Bob Phillips
04-30-2020, 10:47 AM
Ah yes, it is looking at Weekly and Monthly with the database row.

See if this works.


Public Sub CategoryAnalysis()
Const FORMULA_CATEGORY As String = _
"=IFERROR(COUNTIFS(<period>!C10,""P"",<period>!C8,Table!R6C,<period>!C1,Table!RC1)" & _
"/SUMIFS(<period>!C11,<period>!C8,Table!R6C,<period>!C1,Table!RC1),""-"")"
Const FORMULA_SUB_CATEGORY As String = _
"=SUMIFS(<period>!C9,<period>!C1,""<level>"",<period>!C8,Table!R6C,<period>!C4,Table!RC1)"
Dim database As Worksheet
Dim level As String
Dim weeklyrow As Long, monthlyrow As Long
Dim nextrow As Long, lastrow As Long
Dim i As Long

Application.ScreenUpdating = False

Set database = Worksheets("Database")
With Worksheets("Table")

SetupHeadings
nextrow = 7

lastrow = database.Cells(Rows.Count, "A").End(xlUp).Row
level = vbNullString
For i = 2 To lastrow

'setup category row text, formulas and formats
If database.Cells(i, "A").Value <> level Then

level = database.Cells(i, "A").Value
With .Cells(nextrow, "A")

.Value = level
.Font.Italic = False
.HorizontalAlignment = xlLeft
.IndentLevel = 0
End With

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")

With .Cells(nextrow, "C").Resize(1, 10)

.NumberFormat = "0%"
.Font.Size = 10
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With

nextrow = nextrow + 1
End If

'setup sub-category row text, formulas and formats
With .Cells(nextrow, "A")

.Value = database.Cells(i, "D").Value
.Font.Italic = True
.HorizontalAlignment = xlLeft
.IndentLevel = 1
End With

.Cells(nextrow, "B").Value = database.Cells(i, "F").Text

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly"), "<level>", level)
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly"), "<level>", level)

With .Cells(nextrow, "C").Resize(1, 2)

monthlyrow = MatchRow("Monthly", level, database.Cells(i, "D").Value)
If monthlyrow > 0 Then

Select Case Worksheets("Monthly").Cells(monthloyrow, "L").Value

Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
End If
End With

With .Cells(nextrow, "C").Resize(1, 10)

Select Case database.Cells(i, "H").Value

Case "Percentage": .NumberFormat = "0%"
Case "Decimal": .NumberFormat = "#0.000"
End Select
.Font.Size = 8
.Font.Bold = False
.HorizontalAlignment = xlCenter
End With

With .Cells(nextrow, "E").Resize(1, 8)

weeklyrow = MatchRow("Weekly", level, database.Cells(i, "D").Value)
If weeklyrow > 0 Then

Select Case Worksheets("Weekly").Cells(weeklyrow, "L").Value

Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
End If
End With

nextrow = nextrow + 1
Next i
End With

Application.ScreenUpdating = True
End Sub

Private Sub SetupHeadings()

With Worksheets("Table")

.Range("A5:L5").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", "WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
.Range("C5:D5").Interior.Color = RGB(84, 130, 53)
.Range("E5:L5").Interior.Color = RGB(142, 169, 219)
.Range("A5:L5").Font.Color = vbWhite
.Range("A6:B6").Value = Array("CATEGORY", "TARGET")
.Range("A6:D6").Interior.Color = RGB(198, 224, 180)
.Range("E6:L6").Interior.Color = RGB(180, 198, 231)
.Range("C6").FormulaArray = "=MAX(IF(Monthly!C12=Table!R1C2,Monthly!C8))"
.Range("D6").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
.Range("E6").FormulaR1C1 = "=MAX(Weekly!C8)"
.Range("C6:L6").NumberFormat = "dd-mmm"
.Range("F6:L6").FormulaR1C1 = "=RC[-1]-7"
.Range("A5:L6").HorizontalAlignment = xlCenter
.Range("A5:L6").Font.Bold = True
End With
End Sub

Private Function MatchRow(ByRef sh As String, ByVal cat As String, ByVal subcat As String) As Long

On Error Resume Next
MatchRow = Application.Evaluate("Match(1, ('" & sh & "'!A:A=""" & cat & """)*('" & sh & "'!D:D=""" & subcat & """),0)")
End Function

jazz2409
04-30-2020, 08:22 PM
Still the same26522

Bob Phillips
05-01-2020, 01:18 AM
What is that picture supposed to be showing?

jazz2409
05-01-2020, 01:26 AM
I mean for weeks 3/2/2020, 3/23/2020, and 4/13/2020 category 1a is F but on the table they're still color green

Bob Phillips
05-01-2020, 02:20 AM
Ah, you never said you wanted it to be week specific as well, you just mentioned P or F on sub-category, and your example showed applying the same test to all 8 columns, which you plainly cannot do if you are checking the date as well. Weekly might be doable, but what about Monthly? First the vcolumn L already has a value in it, month, and the dates are some MTD, so what date should be checked against?

jazz2409
05-01-2020, 03:05 AM
Hello, can it be like while getting the data for weekly/monthly the value on column L will be checked as well so it wi be colored based on what's in column L? Sorry I'm not really good at explaining things

Bob Phillips
05-01-2020, 03:20 AM
Clearly not. As I said, weekly is simple because the dates in column H are the same dates as we setup on the analysis sheet. Monthly is harder, as column L holds a month value not a P or F, and the date is some date in the month, whereas the analysis is month end date.

This will slow the code down considerably with all the extra looping.

jazz2409
05-01-2020, 03:45 AM
Hmmm on my monthly sheet, I will only have two dates.. Those dates will be the same as what's on the analysis sheet.. And my column L in monthly sheet is the P/F column.. So if the EOMONTH column isn't available on the Monthly Sheet, the color will just be black..
26527

Bob Phillips
05-01-2020, 04:14 AM
You've changed the layout of the Monthly sheet, you added another column before the previous column L. If I was working with you and you did that without telling me I would not be very impressed.

As I said, it is much slower, even on this small set of data.


Public Sub CategoryAnalysis()
Const MSG_TITLE As String = "Category Analysis"
Const HEAD_START As Long = 5
Const FORMULA_CATEGORY As String = _
"=IFERROR(COUNTIFS(<period>!C10,""P"",<period>!C8,Table!R6C,<period>!C1,Table!RC1)" & _
"/SUMIFS(<period>!C11,<period>!C8,Table!R6C,<period>!C1,Table!RC1),""-"")"
Const FORMULA_SUB_CATEGORY As String = _
"=SUMIFS(<period>!C9,<period>!C1,""<level>"",<period>!C8,Table!R6C,<period>!C4,Table!RC1)"
Dim database As Worksheet
Dim level As String
Dim weeklyrow As Long, monthlyrow As Long
Dim nextrow As Long, lastrow As Long
Dim i As Long, ii As Long

On Error GoTo cat_error

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set database = Worksheets("Database")
With Worksheets("Table")

SetupHeadings HEAD_START
nextrow = HEAD_START + 2

lastrow = database.Cells(Rows.Count, "A").End(xlUp).Row
level = vbNullString
For i = 2 To lastrow

'setup category row text, formulas and formats
If database.Cells(i, "A").Value <> level Then

level = database.Cells(i, "A").Value
With .Cells(nextrow, "A")

.Value = level
.Font.Italic = False
.HorizontalAlignment = xlLeft
.IndentLevel = 0
End With

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")

With .Cells(nextrow, "C").Resize(1, 10)

.NumberFormat = "0%"
.Font.Size = 10
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With

nextrow = nextrow + 1
End If

'setup sub-category row text, formulas and formats
With .Cells(nextrow, "A")

.Value = database.Cells(i, "D").Value
.Font.Italic = True
.HorizontalAlignment = xlLeft
.IndentLevel = 1
End With

.Cells(nextrow, "B").Value = database.Cells(i, "F").Text

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly"), "<level>", level)
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly"), "<level>", level)

For ii = 3 To 4

With .Cells(nextrow, ii)

monthlyrow = MatchRow("Monthly", level, database.Cells(i, "D").Value, Worksheets("Table").Cells(HEAD_START + 1, ii).Value)
If monthlyrow > 0 Then

Select Case Worksheets("Monthly").Cells(monthlyrow, "L").Value

Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
End If
End With
Next ii

With .Cells(nextrow, "C").Resize(1, 10)

Select Case database.Cells(i, "H").Value

Case "Percentage": .NumberFormat = "0%"
Case "Decimal": .NumberFormat = "#0.000"
End Select
.Font.Size = 8
.Font.Bold = False
.HorizontalAlignment = xlCenter
End With

For ii = 5 To 12

With .Cells(nextrow, ii)

weeklyrow = MatchRow("Weekly", level, database.Cells(i, "D").Value, Worksheets("Table").Cells(HEAD_START + 1, ii).Value)
If weeklyrow > 0 Then

Select Case Worksheets("Weekly").Cells(weeklyrow, "L").Value

Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
End If
End With
Next ii

nextrow = nextrow + 1
Next i
End With

MsgBox "All done", vbOKOnly + vbInformation, MSG_TITLE

cat_exit:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Exit Sub

cat_error:
MsgBox "Something went wrong" & vbNewLine & _
" error number: " & Err.Number & vbNewLine & _
" error description: " & Err.Description, vbOKOnly + vbCritical, MSG_TITLE
End Sub

Private Sub SetupHeadings(ByVal loc As Long)

With Worksheets("Table").Cells(loc, "A")

.Range("A1:L1").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", "WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
.Range("C1:D1").Interior.Color = RGB(84, 130, 53)
.Range("E1:L1").Interior.Color = RGB(142, 169, 219)
.Range("A1:L1").Font.Color = vbWhite
.Range("A2:B2").Value = Array("CATEGORY", "TARGET")
.Range("A2:D2").Interior.Color = RGB(198, 224, 180)
.Range("E2:L2").Interior.Color = RGB(180, 198, 231)
.Range("C2").FormulaArray = "=MAX(IF(Monthly!C13=Table!R1C2,Monthly!C8))"
.Range("D2").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
.Range("E2").FormulaR1C1 = "=MAX(Weekly!C8)"
.Range("C2:L2").NumberFormat = "dd-mmm"
.Range("F2:L2").FormulaR1C1 = "=RC[-1]-7"
.Range("A1:L2").HorizontalAlignment = xlCenter
.Range("A1:L2").Font.Bold = True
End With
End Sub

Private Function MatchRow(ByRef sh As String, ByVal cat As String, ByVal subcat As String, ByVal week As Date) As Long

On Error Resume Next
MatchRow = Application.Evaluate("Match(1, ('" & sh & "'!A:A=""" & cat & """)*('" & sh & "'!D:D=""" & subcat & """)*('" & sh & "'!H:H=" & CLng(week) & "),0)")
End Function

Bob Phillips
05-01-2020, 04:52 AM
This is much quicker


Public Sub CategoryAnalysis()
Const MSG_TITLE As String = "Category Analysis"
Const HEAD_START As Long = 5
Const FORMULA_CATEGORY As String = _
"=IFERROR(COUNTIFS(<period>!C10,""P"",<period>!C8,Table!R6C,<period>!C1,Table!RC1)" & _
"/SUMIFS(<period>!C11,<period>!C8,Table!R6C,<period>!C1,Table!RC1),""-"")"
Const FORMULA_SUB_CATEGORY As String = _
"=SUMIFS(<period>!C9,<period>!C1,""<level>"",<period>!C8,Table!R6C,<period>!C4,Table!RC1)"
Dim database As Variant
Dim level As String
Dim weeklyrow As Long, monthlyrow As Long
Dim nextrow As Long, lastrow As Long
Dim i As Long, ii As Long
Dim starttime As Double

On Error GoTo cat_error

starttime = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Worksheets("Weekly")

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("N2").Resize(lastrow - 1).Formula = "=A2&D2&INT(H2)"
End With

With Worksheets("Monthly")

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("N2").Resize(lastrow - 1).Formula = "=A2&D2&INT(H2)"
End With

database = Worksheets("Database").UsedRange
With Worksheets("Table")

SetupHeadings HEAD_START
nextrow = HEAD_START + 2

level = vbNullString
For i = LBound(database, 1) + 1 To UBound(database, 1)

'setup category row text, formulas and formats
If database(i, 1) <> level Then

level = database(i, 1)
With .Cells(nextrow, "A")

.Value = level
.Font.Italic = False
.HorizontalAlignment = xlLeft
.IndentLevel = 0
End With

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")

With .Cells(nextrow, "C").Resize(1, 10)

.NumberFormat = "0%"
.Font.Size = 10
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With

nextrow = nextrow + 1
End If

'setup sub-category row text, formulas and formats
With .Cells(nextrow, "A")

.Value = database(i, 4)
.Font.Italic = True
.HorizontalAlignment = xlLeft
.IndentLevel = 1
End With

.Cells(nextrow, "B").Value = database(i, 6)

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly"), "<level>", level)
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly"), "<level>", level)

For ii = 3 To 4

With .Cells(nextrow, ii)

' monthlyrow = MatchRow("Monthly", level, database(i, 4), Worksheets("Table").Cells(HEAD_START + 1, ii).Value)
monthlyrow = MatchIt("Monthly", level & database(i, 4) & CLng(Worksheets("Table").Cells(HEAD_START + 1, ii).Value))
If monthlyrow > 0 Then

Select Case Worksheets("Monthly").Cells(monthlyrow, "L").Value

Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
End If
End With
Next ii

With .Cells(nextrow, "C").Resize(1, 10)

Select Case database(i, 8)

Case "Percentage": .NumberFormat = "0%"
Case "Decimal": .NumberFormat = "#0.000"
End Select
.Font.Size = 8
.Font.Bold = False
.HorizontalAlignment = xlCenter
End With

For ii = 5 To 12

With .Cells(nextrow, ii)

' weeklyrow = MatchRow("Weekly", level, database(i, 4), Worksheets("Table").Cells(HEAD_START + 1, ii).Value)
weeklyrow = MatchIt("Weekly", level & database(i, 4) & CLng(Worksheets("Table").Cells(HEAD_START + 1, ii).Value))
If weeklyrow > 0 Then

Select Case Worksheets("Weekly").Cells(weeklyrow, "L").Value

Case "P": .Font.Color = vbGreen
Case "F": .Font.Color = vbRed
End Select
End If
End With
Next ii
Debug.Print nextrow
nextrow = nextrow + 1
Next i
End With

Worksheets("Weekly").Columns("N").Delete
Worksheets("Monthly").Columns("N").Delete

Debug.Print "Elapsed time: " & Timer - starttime
MsgBox "All done", vbOKOnly + vbInformation, MSG_TITLE

cat_exit:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Exit Sub

cat_error:
MsgBox "Something went wrong" & vbNewLine & _
" error number: " & Err.Number & vbNewLine & _
" error description: " & Err.Description, vbOKOnly + vbCritical, MSG_TITLE
End Sub

Private Sub SetupHeadings(ByVal loc As Long)

With Worksheets("Table").Cells(loc, "A")

.Range("A1:L1").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", "WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
.Range("C1:D1").Interior.Color = RGB(84, 130, 53)
.Range("E1:L1").Interior.Color = RGB(142, 169, 219)
.Range("A1:L1").Font.Color = vbWhite
.Range("A2:B2").Value = Array("CATEGORY", "TARGET")
.Range("A2:D2").Interior.Color = RGB(198, 224, 180)
.Range("E2:L2").Interior.Color = RGB(180, 198, 231)
.Range("C2").FormulaArray = "=MAX(IF(Monthly!C13=Table!R1C2,Monthly!C8))"
.Range("D2").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
.Range("E2").FormulaR1C1 = "=MAX(Weekly!C8)"
.Range("C2:L2").NumberFormat = "dd-mmm"
.Range("F2:L2").FormulaR1C1 = "=RC[-1]-7"
.Range("A1:L2").HorizontalAlignment = xlCenter
.Range("A1:L2").Font.Bold = True
End With
End Sub

Private Function MatchRow(ByRef sh As String, ByVal cat As String, ByVal subcat As String, ByVal week As Date) As Long

On Error Resume Next
MatchRow = Application.Evaluate("Match(1, ('" & sh & "'!A:A=""" & cat & """)*('" & sh & "'!D:D=""" & subcat & """)*('" & sh & "'!H:H=" & CLng(week) & "),0)")
End Function

Private Function MatchIt(ByRef sh As String, ByVal lookupval) As Long

On Error Resume Next
MatchIt = Application.Match(lookupval, Worksheets(sh).Columns(14), 0)
End Function

jazz2409
05-01-2020, 07:08 PM
works perfectly :bow::bow::bow::bow::bow:
thank you so much for being so patient with me. :clap:

jazz2409
05-01-2020, 08:36 PM
Wait I just noticed... The others are not being colored, they remain black
26542

jazz2409
05-01-2020, 08:56 PM
I've fixed it :)
26543
thank you, xld (http://www.vbaexpress.com/forum/member.php?2139-xld) :bow::clap:

Bob Phillips
05-02-2020, 05:32 AM
What was the problem/fix? Was it no value in the Weekly column?

jazz2409
05-02-2020, 06:35 AM
What was the problem/fix? Was it no value in the Weekly column?

Honestly I'm not sure. I edited the HEADSTART + 1 but when I compared it to your codes here, it's the same. So technically I didn't change anything but for some reason it didn't work the first time. Weird.

Bob Phillips
05-02-2020, 10:06 AM
I also noticed that in your pic in post #50, there seems to be two extra lines. Are you still getting that, as I saw that here at some point and know the cause and how to fix it.

jazz2409
05-02-2020, 08:19 PM
Yes that's still showing, I just removed them in post 51 :D

Also in this part:


'setup sub-category row text, formulas and formats With .Cells(nextrow, "A")

.Value = database.Cells(i, "D").Value
.Font.Italic = True
.HorizontalAlignment = xlLeft
.IndentLevel = 1
End With

.Cells(nextrow, "B").Value = database.Cells(i, "F").Text

.Cells(nextrow, "C").Resize(1, 2).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly"), "<level>", level)
.Cells(nextrow, "E").Resize(1, 8).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly"), "<level>", level)

What can be done in order to just copy and paste everything in database.Cells(i,"F") as they are? The percentages are changing to decimals :(

SamT
05-03-2020, 02:03 AM
.Cells(nextrow, "B").Text = da...

Bob Phillips
05-03-2020, 03:24 AM
Sam's suggestion won't work. Text is a read-only property.

This revamped code is tidier, and should address the outstanding issues.


Const MSG_TITLE As String = "Category Analysis"
Const HEAD_START As Long = 5
Const FORMULA_CATEGORY As String = _
"=IFERROR(COUNTIFS(<period>!C10,""P"",<period>!C8,Table!R6C,<period>!C1,Table!RC1)" & _
"/SUMIFS(<period>!C11,<period>!C8,Table!R6C,<period>!C1,Table!RC1),""-"")"
Const FORMULA_SUB_CATEGORY As String = _
"=SUMIFS(<period>!C9,<period>!C1,""<level>"",<period>!C8,Table!R6C,<period>!C4,Table!RC1)"

Public Sub CategoryAnalysis()
Dim database As Variant
Dim category As String
Dim weeklyrow As Long, monthlyrow As Long
Dim numItems As Long, items As Variant
Dim nextrow As Long, lastrow As Long
Dim i As Long, ii As Long
Dim starttime As Double

On Error GoTo cat_error

starttime = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Worksheets("Weekly")

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("N2").Resize(lastrow - 1).Formula = "=A2&D2&INT(H2)"
End With

With Worksheets("Monthly")

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("N2").Resize(lastrow - 1).Formula = "=A2&D2&INT(H2)"
End With

With Worksheets("Database")

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("N2").Resize(lastrow - 1).Formula = "=A2&D2"
database = .Range("A2").Resize(lastrow - 1, 8)
End With

With Worksheets("Table")

SetupHeadings HEAD_START
nextrow = HEAD_START + 2

category = vbNullString
For i = LBound(database, 1) To UBound(database, 1)

'setup category row text, formulas and formats
If database(i, 1) <> category Then

category = database(i, 1)
SetupCategoryRow nextrow, category

nextrow = nextrow + 1
End If

'now setup a sub-category row
SetupSubcategoryRow nextrow, category, database(i, 4)
SetValuesColour Worksheets("Monthly"), nextrow, 3, 4, category, database(i, 4)
SetValuesFormat Worksheets("Table").Cells(nextrow, "C").Resize(1, 10), database(i, 8)
SetValuesColour Worksheets("Weekly"), nextrow, 5, 12, category, database(i, 4)

nextrow = nextrow + 1
Next i
End With

Worksheets("Weekly").Columns("N").Delete
Worksheets("Monthly").Columns("N").Delete
Worksheets("Database").Columns("N").Delete

cat_exit:
Range("A6").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "All done", vbOKOnly + vbInformation, MSG_TITLE

Debug.Print "Elapsed time: " & Timer - starttime
Exit Sub

cat_error:
MsgBox "Something went wrong" & vbNewLine & _
" error number: " & Err.Number & vbNewLine & _
" error description: " & Err.Description, vbOKOnly + vbCritical, MSG_TITLE
End Sub

Private Function SetupHeadings(ByVal loc As Long) As Boolean
With Worksheets("Table").Cells(loc, "A")
.Range("A1:L1").Value = Array(vbNullString, vbNullString, "MTD", "MTD -1", _
"WEEK 0", "WEEK -1", "WEEK -2", "WEEK -3", "WEEK -4", "WEEK -5", "WEEK -6", "WEEK -7")
.Range("C1:D1").Interior.Color = RGB(84, 130, 53)
.Range("E1:L1").Interior.Color = RGB(142, 169, 219)
.Range("A1:L1").Font.Color = vbWhite
.Range("A2:B2").Value = Array("CATEGORY", "TARGET")
.Range("A2:D2").Interior.Color = RGB(198, 224, 180)
.Range("E2:L2").Interior.Color = RGB(180, 198, 231)
.Range("C2").FormulaArray = "=MAX(IF(Monthly!C13=Table!R1C2,Monthly!C8))"
.Range("D2").FormulaR1C1 = "=EOMONTH(RC[-1],-1)"
.Range("E2").FormulaR1C1 = "=MAX(Weekly!C8)"
.Range("C2:L2").NumberFormat = "dd-mmm"
.Range("F2:L2").FormulaR1C1 = "=RC[-1]-7"
.Range("A1:L2").HorizontalAlignment = xlCenter
.Range("A1:L2").Font.Bold = True
End With
End Function

Public Function SetupCategoryRow(ByVal TargetRow As Long, ByVal category As Variant) As Boolean

With Worksheets("Table")

With .Cells(TargetRow, "A")

.Value = category
.Font.Italic = False
.HorizontalAlignment = xlLeft
.IndentLevel = 0
End With

.Cells(TargetRow, "C").Resize(1, 2).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Monthly")
.Cells(TargetRow, "E").Resize(1, 8).FormulaR1C1 = Replace(FORMULA_CATEGORY, "<period>", "Weekly")

With .Cells(TargetRow, "C").Resize(1, 10)

.NumberFormat = "0%"
.Font.ColorIndex = xlColorIndexAutomatic
.Font.Size = 10
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
End With
End Function

Public Function SetupSubcategoryRow(ByVal TargetRow As Long, ByVal category As Variant, ByVal Subcategory As Variant) As Boolean
Dim matchidx As Long

With Worksheets("Table")

With .Cells(TargetRow, "A")

.Value = Subcategory
.Font.Italic = True
.HorizontalAlignment = xlLeft
.IndentLevel = 1
End With

matchidx = MatchIt(category & Subcategory, Worksheets("Database").Columns(14))
If matchidx > 0 Then

.Cells(TargetRow, "B").Value = Worksheets("Database").Cells(matchidx, "F").Text
.Cells(TargetRow, "B").NumberFormat = Worksheets("Database").Cells(matchidx, "F").NumberFormat
End If

.Cells(TargetRow, "C").Resize(1, 2).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly"), "<level>", category)
.Cells(TargetRow, "E").Resize(1, 8).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Weekly"), "<level>", category)
End With
End Function

Private Function SetValuesColour(ByRef sh As Worksheet, ByVal TargetRow As Long, ByVal StartCol As Long, EndCol As Long, _
ByVal category As String, Subcategory As Variant) As Boolean
Dim matchRow As Long
Dim i As Long

With Worksheets("Table")

For i = StartCol To EndCol

matchRow = MatchIt(category & Subcategory & CLng(.Cells(HEAD_START + 1, i).Value), sh.Columns(14))
If matchRow > 0 Then

Select Case sh.Cells(matchRow, "L").Value

Case "P": .Cells(TargetRow, i).Font.Color = vbGreen
Case "F": .Cells(TargetRow, i).Font.Color = vbRed
End Select
End If
Next i
End With
End Function

Private Function SetValuesFormat(ByRef Target As Range, ByVal FormatValue As Variant) As Boolean

With Target

Select Case FormatValue

Case "Percentage": .NumberFormat = "0%"
Case "Decimal": .NumberFormat = "#0.000"
End Select
.Font.Size = 8
.Font.Bold = False
.HorizontalAlignment = xlCenter
End With
End Function

Private Function MatchIt(ByVal lookupval, ByVal LookupIn As Range) As Long
On Error Resume Next
MatchIt = Application.Match(lookupval, LookupIn, 0)
End Function

jazz2409
05-03-2020, 07:59 PM
Let me try :)

jazz2409
05-04-2020, 12:32 AM
I have a question, though.


'now setup a sub-category row SetupSubcategoryRow nextrow, category, database(i, 4)
SetValuesColour Worksheets("Monthly"), nextrow, 3, 4, category, database(i, 4)
SetValuesFormat Worksheets("Table").Cells(nextrow, "C").Resize(1, 10), database(i, 8)
SetValuesColour Worksheets("Weekly"), nextrow, 5, 12, category, database(i, 4)

My Format column in Database has been moved to column J because they added a new column in before Format column. I tried changing it to:


'now setup a sub-category row SetupSubcategoryRow nextrow, category, database(i, 4)
SetValuesColour Worksheets("Monthly"), nextrow, 3, 4, category, database(i, 4)
SetValuesFormat Worksheets("Table").Cells(nextrow, "C").Resize(1, 10), database(i, 10)
SetValuesColour Worksheets("Weekly"), nextrow, 5, 12, category, database(i, 4)

but I got an error saying Subscript out of range so I changed


With Worksheets("Database")

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("N2").Resize(lastrow - 1).Formula = "=A2&D2"
database = .Range("A2").Resize(lastrow - 1, 8)
End With

to


With Worksheets("Database")

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("N2").Resize(lastrow - 1).Formula = "=A2&D2"
database = .Range("A2").Resize(lastrow - 1, 10)
End With

but I got more errors after that. What do I do?

Bob Phillips
05-04-2020, 01:26 AM
Why did you change it to database (i, 10) instead of database (I, 9) if you only added one column?

What I tend to do in my work is to create a column enum, and reference columns numbers by the enum entry, then if I add a column I just add an item to the enum.

Something like this


Enum colDatabase
Category = 1
X1
X2
Subcategory
X3
Target
X4
Format
End Enum

and then I would refence database like so


SetValuesFormat Worksheets("Table").Cells(nextrow, "C").Resize(1, 10), database(i, colDatabase.Format)

and then in your case you would just add a line X5 or some such before Format and no need to change any of the coding statements.

Bob Phillips
05-04-2020, 01:31 AM
BTW, I just made the two changes you identified, and it ran fine for me.

jazz2409
05-04-2020, 01:33 AM
They added two columns: Age of buyer and Annual Income (not sure why)

Bob Phillips
05-04-2020, 02:27 AM
Yeah, I noticed after posting that you said column J.

jazz2409
05-05-2020, 06:50 PM
It's all good now. Thank you so much :)
They no longer added the columns :)

Bob Phillips
05-06-2020, 03:11 AM
As I said Jazz, when I added the columns and made the changes you suggested, it worked fine.

I have an update that makes changes like that more manageable, I added the Enums I mentioned, and also configured it so that you can change where the layout starts (the row number). The business should drive the IT, niot the other way around.

Do you want that version ?

jazz2409
05-06-2020, 11:07 PM
Hmmm it's okay :)

Quick question, though. I am trying to use your way of coding in this particular question.
This time I am trying to create a table showing whether they are P or F instead of the numbers.
The formula I am using is


=LOOKUP(2,1/(Monthly!A:A=Table!B9)/(Monthly!D:D=Table!C10)/(Monthly!J:J=Table!G8),(Monthly!L:L))
This works if I type it manually in a cell.

And my attempt at translating it is:


Const FORMULA_SUB_CATEGORY As String = _
"=LOOKUP(2,1/(<period>!C1=<level>)/(<period>!C4=Table!C3)/(<period>!C10=Table!R8C),(<period>!C12)"

But I am getting an error here:


.Cells(targetrow, "T").Resize(1, 2).FormulaR1C1 = Replace(Replace(FORMULA_SUB_CATEGORY, "<period>", "Monthly"), "<level>", """" & category & """")

It says application defined or object defined error. What am I doing wrong?

jazz2409
05-07-2020, 02:35 AM
Hi, okay so I solved it. I just forgot the other ) at the end :rofl:
But it's super slow like it's taking over 5 minutes for that table alone -_-

Bob Phillips
05-07-2020, 02:39 AM
Try using the version I posted in #48, as I said it was much quicker.

jazz2409
05-07-2020, 03:39 AM
Yes that's what I am using but it's so slow.. Here's my new sample workbook. I made adjustments to it based on what they requested to change.

Maybe you could change the other table.. :help

Bob Phillips
05-07-2020, 07:14 AM
I ran it five times, and these were the timings

Elapsed time: 7.84765625
Elapsed time: 4.46484375
Elapsed time: 2.8515625
Elapsed time: 2.64453125
Elapsed time: 2.93359375

Even 7.8 seconds, whilst slower than I was getting originally, is not unacceptable IMO, 3 secs certainly isn't.

jazz2409
05-07-2020, 07:19 AM
Uhmm my raw data actually has 7620 rows.. and 15 columns :banghead:
But it's okay now we used INDEX MATCH instead using the helper columns created during runtime.

jazz2409
05-10-2020, 04:46 PM
wrong thread.

jazz2409
05-12-2020, 11:24 PM
Another question, though. How do I change the formula for Category rows (monthly and weekly) if for example, I filter the owner to a specific owner and then I filter the group?
Like in the picture below: I filtered the owner Bob and then I filtered just group 2 under group column. the resulting number for category row for monthly and weekly should show either 100%, 50% or 0% only since there are only 2 sub categories under group 2

26650

snb
05-13-2020, 03:12 AM
I don't see the problem.
If you use VBA instead of Excel formulae the results appear in less than 1 msec.

jazz2409
05-13-2020, 03:30 AM
I don't see the problem.
If you use VBA instead of Excel formulae the results appear in less than 1 msec.

Yes it's just that the dates change based on what month you'll choose on G1

Anyway I was told to no longer do post 73 :)

snb
05-13-2020, 03:32 AM
That is just so simple to adapt.

SamT
05-13-2020, 06:01 PM
@ snb,

the problem is that this not just a Report designed by a management committee, this is a Data Base to be used as a Report designed by a management committee and the OP must hack the Data Base directly for each Report, rather than using the Data Base as a source of Data for any Reports.

Further confounding the issue is that the Data Base Fields contain two Types of data, either Percent or Int/Long. AFAIK even the same Named Record could use different Types on different Dates

snb
05-14-2020, 01:27 AM
@Sam

Can you show me where in my file the results differ from the desired results ?

SamT
05-14-2020, 10:38 AM
?