vba create summary on same sheet

Question

I was wondering if anyone knew of a VBA code that looks at the data in a worksheet and can more less do a countif function on the same sheet that contains the data. The following is my data:

         A                        B

  Number               Dept

       1                      2505

       2                      2506

       3                      2905

       4                      2506

Now what I would like to do is use a VBA code to find the last row that contains this data, skip a row and then create a list of each department(only once) and then count how many times each department is in the above data. Basically making a data table or summary table. The result should look like the following.

 Dept                    Issued

 2505                         1

 2506                         2

 2905                         1

Thanks in advance for any help

Answer 1

First the explanation of why we were seeing double-entry of one of the department codes: Turns out that in using the Advanced Filtering to get unique list of entries, it wants to use the first entry as a label for the resulting created unique list.  I've changed the code to take that into account.  Notice that I changed from using "FirstDataRow = 2" to "DeptLabelRow = 1" up in the declarations.  That causes a couple of downstream changes to put the formulas into the correct rows (not putting one next to the new "Dept" label in the unique list).

I also added some code to clear the contents of all rows below the end of the 'source list' - that's in case you delete some entries within it or modify it such that it doesn't have as many departments listed in it as were there when a unique list was created previously - we might only write the remaining department information, but there could be old entries below that remaining from now unused departments.

The revised code:

Sub MakeSummaryCount()

  'change these to match your worksheet layout

  Const NumberCol = "A"

  Const DeptCol = "B"

  Const DeptLabelRow = 1

  'working variables

  Dim lastListRow As Long

  Dim firstNewRow As Long

  Dim deptList As Range

  Dim deptListColNumber As Integer

  Dim lastUsedRow As Long

  lastUsedRow = ActiveSheet.UsedRange.Rows.Count

  lastListRow = Range(NumberCol & DeptLabelRow).End(xlDown).Row

  firstNewRow = lastListRow + 2

'clean up any old summary information below the original list

'if you have anything below the last row in the list of departments

'in any column of the workbook, don't include  the next 3 lines

  If lastUsedRow > lastListRow Then

    Rows(lastListRow + 1 & ":" & lastUsedRow).ClearContents

  End If

  Range("B" & firstNewRow) = "ISSUED"

  'create unique list

  Set deptList = Range(DeptCol & DeptLabelRow & ":" & _

   DeptCol & lastListRow)

'use advanced filtering to create unique list of Departments

'NOTE: Advanced Filtering used in this way uses the 1st entry

'in the source list as a label - which can end up making it

'appear as if it has entered one data field twice if you don't

'actually have a label in the first cell of the source list - JLL

  deptList.AdvancedFilter Action:=xlFilterCopy, _

   CopyToRange:=Range("A" & firstNewRow), Unique:=True

  'get address of the new unique list entries

  deptListColNumber = deptList.Column

  'reuse deptList for this

  Set deptList = Range("A" & firstNewRow + 1 & ":" & _

   Range("A" & firstNewRow).End(xlDown).Address)

'create a COUNTIF() formula for column B in the summary area

  deptList.Offset(0, 1).FormulaR1C1 = _

   "=COUNTIF(R" & DeptLabelRow + 1 & "C" & deptListColNumber & _

    ":R" & lastListRow & "C" & deptListColNumber & _

    ",RC[-1])"

'this converts the formulas to values

  deptList.Offset(0, 1).Formula = deptList.Offset(0, 1).Value

  Set deptList = Nothing

End Sub

Answer 2

Hi,

I noticed my mistake and reposted my code that counts instead of summing, here it is again

Sub Summarise()

Dim Lastrow As Long, x As Long

Dim FirstRow As Long

Dim MyRange, c As Range

Lastrow = Cells(Cells.Rows.Count, "B").End(xlUp).Row

FirstRow = Lastrow + 2

Set MyRange = Range("B2:B" & Lastrow)

Cells(FirstRow, 1) = Cells(1, 1)

Cells(FirstRow, 2) = Cells(1, 2)

For Each c In MyRange

    If IsError(Application.Match(c.Value, _

    Range("A" & FirstRow).Resize(x + 1), 0)) Then

    x = x + 1

    Range("A" & FirstRow + x).Value = c.Value

    Range("A" & FirstRow + x).Offset(, 1).Value = _

    WorksheetFunction.CountIf(MyRange, c.Value)

    End If

Next

End Sub

Answer 3

Ok, both codes are very close. I am having some issues with both though.

Mike H.

The code Fits perfect in the area that it is needed

The problem is it more less sums the numbers instead of counting how many times each department number appears in column B.

JLLatham

The sheet isn't full of data so the last row could be 50, but it changes everytime I run the report. The data in the table works perfect with counting how many times each department appears, but at the end of the table, I get 0 the whole way down to row 65536.

I'm messing around trying to mix the 2, no luck yet, but will continue to work on it. It's like if parts of both codes could be combined, it would work perfectly.

Thanks for the help thus far

Answer 4

Try this code:

Sub MakeSummaryCount()

  'change these to match your worksheet layout

  Const NumberCol = "A"

  Const DeptCol = "B"

  Const FirstDataRow = 2

  'working variables

  Dim lastListRow As Long

  Dim firstNewRow As Long

  Dim deptList As Range

  Dim deptListColNumber As Integer

  lastListRow = Range(NumberCol & FirstDataRow).End(xlDown).Row

  firstNewRow = lastListRow + 2

  Range("A" & firstNewRow) = "DEPT"

  Range("B" & firstNewRow) = "ISSUED"

  firstNewRow = firstNewRow + 1

  'create unique list

  Set deptList = Range(DeptCol & FirstDataRow & ":" & _

   DeptCol & lastListRow)

'use advanced filtering to create unique list of Departments

  deptList.AdvancedFilter Action:=xlFilterCopy, _

   CopyToRange:=Range("A" & firstNewRow), Unique:=True

  'get address of the new unique list entries

  deptListColNumber = deptList.Column

  'reuse deptList for this

  Set deptList = Range("A" & firstNewRow & ":" & _

   Range("A" & firstNewRow).End(xlDown).Address)

'create a COUNTIF() formula for column B in the summary area

  deptList.Offset(0, 1).FormulaR1C1 = _

   "=COUNTIF(R" & FirstDataRow & "C" & deptListColNumber & _

    ":R" & lastListRow & "C" & deptListColNumber & _

    ",RC[-1])"

  Set deptList = Nothing

End Sub

Answer 5

Hi,

Try this

Sub Summarise()

Dim Lastrow As Long, x As Long

Dim FirstRow As Long

Dim MyRange, c As Range

Dim SumRange As Range

Lastrow = Cells(Cells.Rows.Count, "B").End(xlUp).Row

FirstRow = Lastrow + 2

Set MyRange = Range("B2:B" & Lastrow)

Set SumRange = Range("A2:A" & Lastrow)

Cells(FirstRow, 1) = Cells(1, 1)

Cells(FirstRow, 2) = Cells(1, 2)

For Each c In MyRange

    If IsError(Application.Match(c.Value, _

    Range("A" & FirstRow).Resize(x + 1), 0)) Then

    x = x + 1

    Range("A" & FirstRow + x).Value = c.Value

    Range("A" & FirstRow + x).Offset(, 1).Value = _

    WorksheetFunction.SumIf(MyRange, c.Value, SumRange)

    End If

Next

End Sub

Code edited to incllude headers in summary

Second edit... You wanted count not sum so try this

Sub Summarise()

Dim Lastrow As Long, x As Long

Dim FirstRow As Long

Dim MyRange, c As Range

Lastrow = Cells(Cells.Rows.Count, "B").End(xlUp).Row

FirstRow = Lastrow + 2

Set MyRange = Range("B2:B" & Lastrow)

Cells(FirstRow, 1) = Cells(1, 1)

Cells(FirstRow, 2) = Cells(1, 2)

For Each c In MyRange

    If IsError(Application.Match(c.Value, _

    Range("A" & FirstRow).Resize(x + 1), 0)) Then

    x = x + 1

    Range("A" & FirstRow + x).Value = c.Value

    Range("A" & FirstRow + x).Offset(, 1).Value = _

    WorksheetFunction.CountIf(MyRange, c.Value)

    End If

Next

End Sub