VBA detects where to stop counting

K

kiwi101

New Member
Joined
Jun 28, 2016
Messages
16
Hello everyone,

My problem is fairly simple. I have a table I am working with which divides students into subjects Art or Math. For example,

Student|Subj. | T | | M
Kayline | Arts | 1 | 3 | 4
Loloita | Arts | 0 | 2 | 1
Gerard | Arts| 4 | 4 | 2
Jocelyn | Math| 2 | 2 | 3
.
.
.

I now create 2 new tables which calculate the mode of values ranging from 0-4 for Arts students and Math Students. I then create 2 new tables which calculate the percentage of these modes relative to all values. For example, 20% of the answers for Question "T" are 1 for Arts students. I then create a table to show all this.
I have managed to do this with Record Macro. However my main problem is, is there a way I can make the macro itself stop counting at the last student who takes Art instead of manually having to add the cell number. And the same goes for Math table. Is there a way I can get the macro to start counting from the first Math student until the last without having to manually plug in cell numbers?

Current Code:
Sub Test2()
'
' Test2 Macro
'

'
Sheets.Add After:=ActiveSheet
Range("B1").Select
ActiveCell.FormulaR1C1 = "t"
Range("C1").Select
ActiveCell.FormulaR1C1 = "c"
Range("D1").Select
ActiveCell.FormulaR1C1 = "m"
Range("A2").Select
ActiveCell.FormulaR1C1 = "0"
Range("A3").Select
ActiveCell.FormulaR1C1 = "1"
Range("A4").Select
ActiveCell.FormulaR1C1 = "2"
Range("A5").Select
ActiveCell.FormulaR1C1 = "3"
Range("A6").Select
ActiveCell.FormulaR1C1 = "4"
Range("B2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(Sheet1!R3C5:R34C5,RC[-1])"
Range("B2").Select
Selection.AutoFill Destination:=Range("B2:B6"), Type:=xlFillDefault
Range("B2:B6").Select
Range("C2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(Sheet1!R3C6:R34C6,RC[-2])"
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C6"), Type:=xlFillDefault
Range("C2:C6").Select
Range("D2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(Sheet1!R3C7:R34C7,RC[-3])"
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D6"), Type:=xlFillDefault
Range("D2:D6").Select
Range("B8").Select
ActiveCell.FormulaR1C1 = "t"
Range("C8").Select
ActiveCell.FormulaR1C1 = "c"
Range("D8").Select
ActiveCell.FormulaR1C1 = "m"
Range("A9").Select
ActiveCell.FormulaR1C1 = "0"
Range("A10").Select
ActiveCell.FormulaR1C1 = "1"
Range("A11").Select
ActiveCell.FormulaR1C1 = "2"
Range("A12").Select
ActiveCell.FormulaR1C1 = "3"
Range("A13").Select
ActiveCell.FormulaR1C1 = "4"
Range("A14").Select
ActiveCell.FormulaR1C1 = "5"
Range("A14").Select
ActiveCell.FormulaR1C1 = ""
Range("B9").Select
ActiveCell.FormulaR1C1 = "=(R[-7]C/(COUNT(Sheet1!R3C5:R34C5)))*100"
Range("B9").Select
Selection.AutoFill Destination:=Range("B9:B13"), Type:=xlFillDefault
Range("B9:B13").Select
Range("C9").Select
ActiveCell.FormulaR1C1 = "=(R[-7]C/(COUNT(Sheet1!R3C6:R34C6)))*100"
Range("C9").Select
Selection.AutoFill Destination:=Range("C9:C13"), Type:=xlFillDefault
Range("C9:C13").Select
Range("D9").Select
ActiveCell.FormulaR1C1 = "=(R[-7]C/(COUNT(Sheet1!R3C7:R34C7)))*100"
Range("D9").Select
Selection.AutoFill Destination:=Range("D9:D13"), Type:=xlFillDefault
Range("D9:D13").Select
Range("A8:D13").Select
ActiveSheet.Shapes.AddChart2(297, xlColumnStacked100).Select
ActiveChart.SetSourceData Source:=Range("Sheet3!$A$8:$D$13")
ActiveChart.FullSeriesCollection(1).Select
ActiveChart.FullSeriesCollection(1).ApplyDataLabels
ActiveChart.FullSeriesCollection(2).Select
ActiveChart.FullSeriesCollection(2).ApplyDataLabels
ActiveChart.FullSeriesCollection(3).Select
ActiveChart.FullSeriesCollection(3).ApplyDataLabels
Range("T21").Select
Sheets("Sheet1").Select
End Sub
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Sort by date Sort by votes
Ok, question... you are creating two different tables with the above code... one that starts in Cell A1 - D6 and the other that starts on A8 - D13... Is one of these for "Arts" and the other for "Math", or is it just "Arts" and then the second the percentage?

IF there needs to be 4 tables, 1 for Arts Count and 1 or Arts %, 1 for Math Count and 1 for Math %... plus two charts for the % then this should work... if not let me know what needs tweaked...

Code: 
Sub Test2()

Dim ws As Worksheet
Dim a As Integer, m As Integer
Dim Rng As Range, rngArts As Range, rngMath As Range


With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With


ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A:G")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
    
Set Rng = Sheets("Sheet1").Range("B1:B" & Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row)


On Error Resume Next
Set rngArts = Rng.Find(What:="Arts", LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows)
Set rngMath = Rng.Find(What:="Math", LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows)


a = rngArts.Row
m = rngMath.Row


Set ws = Sheets.Add(After:=Worksheets("sheet1"))


With ws
    .Range("A1") = "Arts"
    .Range("I1") = "Math"
    .Range("B1, B8, J1, J8").Formula = "T"
    .Range("C1, C8, K1, K8").Formula = "C"
    .Range("D1, D8, L1, L8").Formula = "M"
    .Range("A2, A9, I2, I9").Formula = "0"
    .Range("A3, A10, I3, I10").Formula = "1"
    .Range("A4, A11, I4, I11").Formula = "2"
    .Range("A5, A12, I5, I12").Formula = "3"
    .Range("A6, A13, I6, I13").Formula = "4"
    
    .Range("B2:B6").Formula = "=COUNTIF(Sheet1!$E$2:$E$" & a & ",A2)"
    .Range("C2:C6").Formula = "=COUNTIF(Sheet1!$F$2:$F$" & a & ",A2)"
    .Range("D2:D6").Formula = "=COUNTIF(Sheet1!$G$2:$G$" & a & ",A2)"
    .Range("J2:J6").Formula = "=COUNTIF(Sheet1!$E$" & a + 1 & ":$E$" & m & ",A9)"
    .Range("K2:K6").Formula = "=COUNTIF(Sheet1!$F$" & a + 1 & ":$F$" & m & ",A9)"
    .Range("L2:L6").Formula = "=COUNTIF(Sheet1!$G$" & a + 1 & ":$G$" & m & ",A9)"
    
    .Range("B9:B13").Formula = "=(B2/(COUNT(Sheet1!$E$2:$E$" & a & ")))*100"
    .Range("C9:C13").Formula = "=(C2/(COUNT(Sheet1!$F$2:$F$" & a & ")))*100"
    .Range("D9:D13").Formula = "=(D2/(COUNT(Sheet1!$G$2:$G$" & a & ")))*100"
    .Range("J9:J13").Formula = "=(J2/(COUNT(Sheet1!$E$" & a + 1 & ":$E$" & m & ")))*100"
    .Range("K9:K13").Formula = "=(K2/(COUNT(Sheet1!$F$" & a + 1 & ":$F$" & m & ")))*100"
    .Range("L9:L13").Formula = "=(L2/(COUNT(Sheet1!$G$" & a + 1 & ":$G$" & m & ")))*100"
End With


ws.Shapes.AddChart.Select


With ActiveChart
    .ChartType = xlColumnStacked100
    .SetSourceData Source:=ws.Range("$A$8:$D$13")
    .SeriesCollection(1).ApplyDataLabels
    .SeriesCollection(2).ApplyDataLabels
    .SeriesCollection(3).ApplyDataLabels
    .SetElement (msoElementChartTitleAboveChart)
    .ChartTitle.Text = "Arts"
    With .Parent
        .Top = Range("C15").Top
        .Left = Range("A15").Left
    End With
End With


ws.Shapes.AddChart.Select
With ActiveChart
    .ChartType = xlColumnStacked100
    .SetSourceData Source:=ws.Range("$I$8:$L$13")
    .SeriesCollection(1).ApplyDataLabels
    .SeriesCollection(2).ApplyDataLabels
    .SeriesCollection(3).ApplyDataLabels
    .SetElement (msoElementChartTitleAboveChart)
    .ChartTitle.Text = "Math"
    With .Parent
        .Top = Range("I15").Top
        .Left = Range("I15").Left
    End With
End With
    
ws.Range("A1").Select


With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With


End Sub
 
Upvote 0
Yes your assumption was right, I am creating 4 tables and 2 charts based on the percentage.
So with this code
It provides a set of 4 empty tables and 2 empty charts with the chart name and table name being displayed.
It doesn't use the set of data I already have to fill up the table and charts.
 
Last edited:
Upvote 0
Also, what part of the code do you mention to stop counting when the last entry is Arts or Math instead of the actual cell number?
 
Upvote 0
kiwi101 said:
It doesn't use the set of data I already have to fill up the table and charts.
Click to expand...

Where is your data stored?

Code: 
[COLOR=#333333]Sub Test2()
[/COLOR]
Dim ws As Worksheet
Dim a As Integer, m As Integer
Dim Rng As Range, rngArts As Range, rngMath As Range

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

[COLOR=#ff0000]'SORTS THE DATA WITHIN COLUMNS A - G BY THE DATA IN COLUMN B (ARTS AND MATH)[/COLOR]
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear 
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal [COLOR=#ff0000]'ASSUMES "ARTS" AND "MATH" ARE IN COLUMN B[/COLOR]
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("A:G") [COLOR=#ff0000]'ASSUMES ALL DATA IS WITHIN COLUMNS A - G[/COLOR]
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
    
Set Rng = Sheets("Sheet1").Range("B1:B" & Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row) [COLOR=#ff0000]'ASSUMES THE NAME OF THE SHEET CONTAINING THE DATA IS SHEET1[/COLOR]

On Error Resume Next
Set rngArts = Rng.Find(What:="Arts", LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows)[COLOR=#ff0000] 'FINDS THE LASTROW THAT CONTAINS THE WORD "ARTS"[/COLOR]
Set rngMath = Rng.Find(What:="Math", LookAt:=xlWhole, SearchDirection:=xlPrevious, SearchOrder:=xlByRows)[COLOR=#ff0000] 'FINDS THE LASTROW THAT CONTAINS THE WORD "MATH"[/COLOR]

a = rngArts.Row
m = rngMath.Row

Set ws = Sheets.Add(After:=Worksheets("sheet1")) [COLOR=#ff0000]'CREATES THE NEW SHEET FOR THE TABLES/CHARTS[/COLOR]

[COLOR=#ff0000]'FROM HERE DOWN CREATES THE TABLES AND CHARTS[/COLOR]
With ws
    .Range("A1") = "Arts"
    .Range("I1") = "Math"
    .Range("B1, B8, J1, J8").Formula = "T"
    .Range("C1, C8, K1, K8").Formula = "C"
    .Range("D1, D8, L1, L8").Formula = "M"
    .Range("A2, A9, I2, I9").Formula = "0"
    .Range("A3, A10, I3, I10").Formula = "1"
    .Range("A4, A11, I4, I11").Formula = "2"
    .Range("A5, A12, I5, I12").Formula = "3"
    .Range("A6, A13, I6, I13").Formula = "4"
    
    .Range("B2:B6").Formula = "=COUNTIF(Sheet1!$E$2:$E$" & a & ",A2)"
    .Range("C2:C6").Formula = "=COUNTIF(Sheet1!$F$2:$F$" & a & ",A2)"
    .Range("D2:D6").Formula = "=COUNTIF(Sheet1!$G$2:$G$" & a & ",A2)"
    .Range("J2:J6").Formula = "=COUNTIF(Sheet1!$E$" & a + 1 & ":$E$" & m & ",A9)"
    .Range("K2:K6").Formula = "=COUNTIF(Sheet1!$F$" & a + 1 & ":$F$" & m & ",A9)"
    .Range("L2:L6").Formula = "=COUNTIF(Sheet1!$G$" & a + 1 & ":$G$" & m & ",A9)"
    
    .Range("B9:B13").Formula = "=(B2/(COUNT(Sheet1!$E$2:$E$" & a & ")))*100"
    .Range("C9:C13").Formula = "=(C2/(COUNT(Sheet1!$F$2:$F$" & a & ")))*100"
    .Range("D9:D13").Formula = "=(D2/(COUNT(Sheet1!$G$2:$G$" & a & ")))*100"
    .Range("J9:J13").Formula = "=(J2/(COUNT(Sheet1!$E$" & a + 1 & ":$E$" & m & ")))*100"
    .Range("K9:K13").Formula = "=(K2/(COUNT(Sheet1!$F$" & a + 1 & ":$F$" & m & ")))*100"
    .Range("L9:L13").Formula = "=(L2/(COUNT(Sheet1!$G$" & a + 1 & ":$G$" & m & ")))*100"
End With

ws.Shapes.AddChart.Select

With ActiveChart
    .ChartType = xlColumnStacked100
    .SetSourceData Source:=ws.Range("$A$8:$D$13")
    .SeriesCollection(1).ApplyDataLabels
    .SeriesCollection(2).ApplyDataLabels
    .SeriesCollection(3).ApplyDataLabels
    .SetElement (msoElementChartTitleAboveChart)
    .ChartTitle.Text = "Arts"
    With .Parent
        .Top = Range("C15").Top
        .Left = Range("A15").Left
    End With
End With

ws.Shapes.AddChart.Select
With ActiveChart
    .ChartType = xlColumnStacked100
    .SetSourceData Source:=ws.Range("$I$8:$L$13")
    .SeriesCollection(1).ApplyDataLabels
    .SeriesCollection(2).ApplyDataLabels
    .SeriesCollection(3).ApplyDataLabels
    .SetElement (msoElementChartTitleAboveChart)
    .ChartTitle.Text = "Math"
    With .Parent
        .Top = Range("I15").Top
        .Left = Range("I15").Left
    End With
End With
    
ws.Range("A1").Select

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

 [COLOR=#333333]End Sub[/COLOR]
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question Question
Help with Vba Code
Replies
3
Views
476
Coyotex3
C
L
  • Question Question
Variable Rows, Help Speeding Up
Replies
4
Views
567
kevin9999
K
B
  • Question Question
VBA causing cell to change incorrectly
Replies
9
Views
543
Bouncy Fire
B
R
  • Question Question
Formatting using VBA
Replies
0
Views
553
RandyD123
R
C
  • Solved
Migrating 2 macros and sorting them
Replies
5
Views
458
Legacy 143009
L

Forum statistics

Threads
1,224,595
Messages
6,179,798
Members
452,943
Latest member
Newbie4296

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top