Revising existing macro to be more dynamic- count the occurrences of usernames based on a date in multiple files and update the tracker

CapG · Jun 4th 2020

Hi!

I have around 20 odd files created everyday and in each file I just have to read Column BI having usernames and column BJ having dates and update the count of occurrences of username on that date.So in the below code I have usernames hard coded which is a drawback if usernames are added/removed I need to change the code every time.Also this report must on a daily basis attached is the tracker file.

Code

Sub Report()
Dim myRange As Range 'letting the user to locate a cell in tracker
Dim dates As Variant 'storing located date
Set myRange = Application.InputBox(Prompt:="Locate a single cell containing date",
Title:="Reporting", Type:=8)
Dim user1, user2, user3, user4 As Variant 'usernames
Dim cnt1, cnt2, cnt3, cnt4, num1, num2, num3, num4 As Long ' counter for matching cell values in column BI and BJ
Const DirName As String = "C:\Users\Offices\"
Const Ext As String = "*.xlsm" 'File extension
Dim NextFn As String ' name of the next file to process
Dim SrcWb As Workbook
NextFn = Dir(DirName & Ext)
Do While NextFn <> ""
Set SrcWb = Workbooks.Open(DirName & NextFn)
cnt1 = Application.WorksheetFunction.CountIfs(Range("BI:BI"), "Andrew", Range("BJ:BJ"), dates)
num1 = num1 + cnt1
cnt2 = Application.WorksheetFunction.CountIfs(Range("BI:BI"), "Liss", Range("BJ:BJ"), dates)
num2 = num2 + cnt2
cnt3 = Application.WorksheetFunction.CountIfs(Range("BI:BI"), "Carry", Range("BJ:BJ"), dates)
num3 = num3 + cnt3
cnt4 = Application.WorksheetFunction.CountIfs(Range("BI:BI"), "Jafree", Range("BJ:BJ"), dates)
num4 = num4 + cnt4
NextFn = Dir
Loop
myRange.Offset(2, 0) = num1
myRange.Offset(3, 0) = num2
myRange.Offset(4, 0) = num3
myRange.Offset(5, 0) = num4
End Sub

Display More

davesexcel · Jun 7th 2020

Your sample workbook needs to show the desired results as well.

Your sample workbook has no data in columns BI & BJ

CapG · Jun 8th 2020

Attached is the sample file.

davesexcel · Jun 8th 2020

Still not clear

**royUK** · Jun 8th 2020

I can't understand either. It would be so much easier to get all the data into one sheet of main workbook.

CapG · Jun 8th 2020

Okay.Let me make you understand.There are around 20 odd workbooks (attached is a sample workbook ie, one among those 20 files please see column BI and BJ) gets generated daily in which users creates ID on a daily basis and that is tracked by columns BI and BJ . Column BI has username and BJ has dates on which ID was created.So in the tracker file (attached) , there are dates/months when selected a particular date that should loop through each workbooks to get a consolidated status of each user and their count of ID's created everyday by running this tracker file.

Hope I made it clear.

dangelor · Jun 8th 2020

Possibly...

Code

Sub Report()
Dim myRange As Range 'letting the user to locate a cell in tracker
Dim dates As Variant 'storing located date
Set myRange = Application.InputBox(Prompt:="Locate a single cell containing date", _
Title:="Reporting", Type:=8)
Dim user1, user2, user3, user4 As Variant 'usernames
Dim cnt1, cnt2, cnt3, cnt4, num1, num2, num3, num4 As Long ' counter for matching cell values in column BI and BJ
Const DirName As String = "C:\Users\Offices\"
Const Ext As String = "*.xlsm" 'File extension
Dim NextFn As String ' name of the next file to process
Dim SrcWb As Workbook
Dim v As Variant, c As Variant
Dim d As Object, i As Long
Set d = CreateObject("Scripting.Dictionary")
NextFn = Dir(DirName & Ext)
Do While NextFn <> ""
Set SrcWb = Workbooks.Open(DirName & NextFn)
v = Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("BI").Offset(5))
For Each c In v
d.Item(c) = d.Item(c) + 1
Next
NextFn = Dir
Loop
For Each v In d
i = i + 1
myRange.Offset(1 + i, 0) = d(v)
Next v
End Sub

Display More

dangelor · Jun 8th 2020

Change this line

Code

v = Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("BI").Offset(5))

to this

Code

v = Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("BI")).Offset(5)

CapG · Jun 10th 2020

Hi dangelor! It seems like the code is looping through each rows in BI to get items(usernames) but not giving exact result if the one of four names is not present in any of the files hence the item 3="Empty".

dangelor · Jun 10th 2020

I made a small change to eliminate the counting of blank cells...

Code

Sub Report()
Dim myRange As Range 'letting the user to locate a cell in tracker
Dim dates As Variant 'storing located date
Set myRange = Application.InputBox(Prompt:="Locate a single cell containing date", _
Title:="Reporting", Type:=8)
Dim user1, user2, user3, user4 As Variant 'usernames
Dim cnt1, cnt2, cnt3, cnt4, num1, num2, num3, num4 As Long ' counter for matching cell values in column BI and BJ
Const DirName As String = "C:\Users\Offices\"
Const Ext As String = "*.xlsm" 'File extension
Dim NextFn As String ' name of the next file to process
Dim SrcWb As Workbook
Dim v As Variant, c As Variant
Dim d As Object, i As Long
Set d = CreateObject("Scripting.Dictionary")
NextFn = Dir(DirName & Ext)
Do While NextFn <> ""
Set SrcWb = Workbooks.Open(DirName & NextFn)
v = Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("BI")).Offset(5)
For Each c In v
If Not IsEmpty(c) Then d.Item(c) = d.Item(c) + 1
Next
NextFn = Dir
Loop
For Each v In d
i = i + 1
myRange.Offset(1 + i, 0) = d(v)
Next v
End Sub

Display More

CapG · Jun 11th 2020

I tried the revised code but the count showing for each user is not accurate. Attached are the two sample files against which I ran the code to check the results.

dangelor · Jun 11th 2020

This should work now...

Code

Sub Report()
Dim myRange As Range 'letting the user to locate a cell in tracker
Dim dates As Variant 'storing located date
Set myRange = Application.InputBox(Prompt:="Locate a single cell containing date", _
Title:="Reporting", Type:=8)
Dim user1, user2, user3, user4 As Variant 'usernames
Dim cnt1, cnt2, cnt3, cnt4, num1, num2, num3, num4 As Long ' counter for matching cell values in column BI and BJ
Const DirName As String = "C:\Users\Offices\"
Const Ext As String = "*.xlsm" 'File extension
Dim NextFn As String ' name of the next file to process
Dim SrcWb As Workbook
Dim v As Variant, c As Variant
Dim d As Object, i As Long
Set d = CreateObject("Scripting.Dictionary")
NextFn = Dir(DirName & Ext)
Do While NextFn <> ""
Set SrcWb = Workbooks.Open(DirName & NextFn)
v = Application.Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("BI")).Offset(4)
For Each c In v
If Not IsEmpty(c) Then d.Item(c) = d.Item(c) + 1
Next
NextFn = Dir
Loop
For Each v In d
i = i + 1
myRange.Offset(1 + i, 0) = d(v)
Next v
End Sub

Display More

CapG · Jun 11th 2020

Thanks dangelor! It worked.

dangelor · Jun 11th 2020

Glad to hear it! Good luck!

Revising existing macro to be more dynamic- count the occurrences of usernames based on a date in multiple files and update the tracker

CapG Jun 4th 2020

Share

Tags