Macro/VBA Code Help

N

nhbartos

Board Regular
Joined
May 23, 2015
Messages
148
Hi folks,

I can use some help on a macro.

Data will be pasted into this file into A2:J, and I need a macro to:

1. Remove all rows where value in column H is 3 or higher.
2. Count or CountA column H for each unique 'Learner' name in column A. (do not subtotal attempts)
3. Output list of learners and their counts on another tab. Column A should be titled "Learner", and column B should be titled "Number of Courses Completed in 2 or Less Attempts".
4. Initial sort on output should be A-Z by 'Learner" column A.

The output on the new tab should be like this:

Learner Number of Courses Completed in 2 or Less Attempts
Learner A 16
Learner B 10
etc...

Total Learners Total Number of Courses Completed in 2 or Less Attempts
60 350

Anybody able to help me with this?

Best,
Vince
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Sort by date Sort by votes
Does this do what you want. Code assumes pasted data is on Sheet1 and desired output will be on Sheet2.

Code: 
Sub learners2()
    
    Dim Olrn, Nlrn, hdr, ftr
    Dim lRow As Long, i As Long, x As Long, n As Long, ct As Long, tct As Long
    Dim nam As String
    
    hdr = Array("Learner", "Number of Courses Completed in 2 or Less Attempts")
    ftr = Array("Total Learners", "Total Number of Courses Completed in 2 or Less Attempts")
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = lRow To 2 Step -1
        If Cells(i, 8) > 2 Then Rows(i).Delete
    Next
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    Olrn = Range("A2:A" & lRow)
    With CreateObject("Scripting.Dictionary")
        For x = LBound(Olrn) To UBound(Olrn)
            If Not IsMissing(Olrn(x, 1)) Then .Item(Olrn(x, 1)) = 1
        Next
        Olrn = .keys
    End With
    
    ReDim Nlrn(0 To UBound(Olrn), 0 To 1)
    For n = LBound(Olrn) To UBound(Olrn)
        nam = Olrn(n)
        ct = Application.WorksheetFunction.SumIf(Range("A2:A" & lRow), nam, Range("H2:H" & lRow))
        Nlrn(n, 0) = nam
        Nlrn(n, 1) = ct
        tct = tct + ct
    Next
    
    With Worksheets("Sheet2")
        .Range("A2").Resize(n, 2) = Nlrn
    End With
    Worksheets("Sheet2").Activate
    Range("A2:B" & n + 1).Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("A2:A" & n + 1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A2:B" & n + 1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    With Worksheets("Sheet2")
        .Range("A1:B1") = hdr
        .Range("A" & n + 3 & ":B" & n + 3) = ftr
        .Range("A" & n + 4) = n
        .Range("B" & n + 4) = tct
        .Range("A1").Select
    End With
    
End Sub
 
Upvote 0
Hello!
Thank you so much for your time.
I am not getting what I need however.

This is how I prepared initial file output, to match your code:
1. Our output file is an.xlsx. I saved as an .xlsm
2. Renamed ExamSubmissions tab as sheet1
3. Deleted coverpage tab
4. Inserted sheet2
(Is there anyway to write code to make the above changes before running the counts code)
5. Ran the code.

Here is a link to the initial file and the file after I ran the code.
https://drive.google.com/open?id=1XVxu8HFowkXlBYWULbLrbnwIHk4LGlnH


Thank you a ton!
Vince
 
Upvote 0
Hi Vince,

I believe the problem is that in your OP you said that the "Attempts" column was column H, when in fact it is column G. Try this...

Code: 
Sub learners2()
    
    Dim Olrn, Nlrn, hdr, ftr
    Dim lRow As Long, i As Long, x As Long, n As Long, ct As Long, tct As Long
    Dim nam As String
    
    Application.ScreenUpdating = False
    hdr = Array("Learner", "Number of Courses Completed in 2 or Less Attempts")
    ftr = Array("Total Learners", "Total Number of Courses Completed in 2 or Less Attempts")
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = lRow To 2 Step -1
        If Cells(i, 7) > 2 Then Rows(i).Delete
    Next
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    Olrn = Range("A2:A" & lRow)
    With CreateObject("Scripting.Dictionary")
        For x = LBound(Olrn) To UBound(Olrn)
            If Not IsMissing(Olrn(x, 1)) Then .Item(Olrn(x, 1)) = 1
        Next
        Olrn = .keys
    End With
    
    ReDim Nlrn(0 To UBound(Olrn), 0 To 1)
    For n = LBound(Olrn) To UBound(Olrn)
        nam = Olrn(n)
        ct = Application.WorksheetFunction.SumIf(Range("A2:A" & lRow), nam, Range("G2:G" & lRow))
        Nlrn(n, 0) = nam
        Nlrn(n, 1) = ct
        tct = tct + ct
    Next
    
    With Worksheets("Sheet2")
        .Range("A2").Resize(n, 2) = Nlrn
    End With
    Worksheets("Sheet2").Activate
    Range("A2:B" & n + 1).Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("A2:A" & n + 1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A2:B" & n + 1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    With Worksheets("Sheet2")
        .Range("A1:B1") = hdr
        .Range("A" & n + 3 & ":B" & n + 3) = ftr
        .Range("A" & n + 4) = n
        .Range("B" & n + 4) = tct
        .Range("A1").Select
    End With
    Application.ScreenUpdating = True
     
End Sub

See if this does what you want with the raw data. If it does, we can work on your other requirements later. I have to run out for a while now.
 
Last edited:
Upvote 0
Hi,

Ok, this should do the raw data conversion (if you will). As far as your Red highlights go- that looks like you ran the code more than once without deleting the prior results from Sheet2.

Code: 
Sub learners2()
    
    Dim Olrn, Nlrn, hdr, ftr
    Dim lRow As Long, i As Long, x As Long, n As Long, ct As Long
    Dim nam As String
    
    Application.ScreenUpdating = False
    hdr = Array("Learner", "Number of Courses Completed in 2 or Less Attempts")
    ftr = Array("Total Learners", "Total Number of Courses Completed in 2 or Less Attempts")
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    For i = lRow To 2 Step -1
        If Cells(i, 7) > 2 Then Rows(i).Delete
    Next
    lRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    Olrn = Range("A2:A" & lRow)
    With CreateObject("Scripting.Dictionary")
        For x = LBound(Olrn) To UBound(Olrn)
            If Not IsMissing(Olrn(x, 1)) Then .Item(Olrn(x, 1)) = 1
        Next
        Olrn = .keys
    End With
    
    ReDim Nlrn(0 To UBound(Olrn), 0 To 1)
    For n = LBound(Olrn) To UBound(Olrn)
        nam = Olrn(n)
        ct = Application.WorksheetFunction.SumIf(Range("A2:A" & lRow), nam, Range("G2:G" & lRow))
        Nlrn(n, 0) = nam
        Nlrn(n, 1) = ct
    Next
    
    With Worksheets("Sheet2")
        .Range("A2").Resize(n, 2) = Nlrn
    End With
    Worksheets("Sheet2").Activate
    Range("A2:B" & n + 1).Select
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("A2:A" & n + 1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("A2:B" & n + 1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    With Worksheets("Sheet2")
        .Range("A1:B1") = hdr
        .Range("A" & n + 3 & ":B" & n + 3) = ftr
        .Range("A" & n + 4) = n
        .Range("B" & n + 4) = lRow - 1
        .Range("A1").Select
    End With
     Application.ScreenUpdating = True
     
End Sub
If this gets you the results you want we can then go on an further customize it. Including clearing what is now Sheet2 prior to a subsequent run.
 
Upvote 0
It looks like it is still summing column G instead of just counting cells with content.
See link.
https://drive.google.com/open?id=1XnHGkkwsMDbFGKxMwJ9UyIU6E7GJ8D1E

Thanks again for your help! This looks good otherwise. I also appreciate your willingness to customize.

When we are ready, I just want to get it written down, but this is what I am trying to get to:
1. change code so we can keep the original tab names: sheet1= ExamSubmissions
2. I would like to keep tab Coversheet as is.
3. Insert sheet2 for output and rename: Summary
4. Have Summary formatted for reporting as I have shown. Is it too much trouble to duplicate this format? I need to be able to enter a logo and other info in the header.


Vince
 
Upvote 0
If you look at the last row of names on sheet1, your count in column G should be one less.

When we are ready the customization's you want should be easy...(famous last words)
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Macro to count the number times the excel/powerpoint has been opened
2
Replies
14
Views
298
Jeffrey Mahoney
Jeffrey Mahoney
J
  • Question Question
Using Sheets().Select in a Worksheet_Activate() macro
2
Replies
10
Views
476
jdun
J
D
  • Solved
Formula for column for (sort of) running count
Replies
7
Views
124
Peter_SSs
Peter_SSs
C
  • Question Question
Macro Help - Transposing Some Data from Columns to Rows, Accounting for Duplicate Data
Replies
1
Views
133
Kaper
Kaper
D
  • Solved
Counting Consecutive Blanks
Replies
9
Views
708
felixstraube
F

Forum statistics

Threads
1,224,856
Messages
6,181,424
Members
453,039
Latest member
jr25673

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