PDA

View Full Version : VBA code to store and count data filtered by other columns



Chrisalisk
02-05-2017, 03:48 PM
Hi all!

I've been trying to develop a macro that will do the following to the example doc

Filter column B that contains either "realease" or "draft" to only show "released" items
Lookup in column F and store all possible filter options - In this instance names (lots of names associated with the "released" items and these can change so needs to store all options when run)
Next, count the number of instances these 'stored names' appear for released items - I.e. Alan has 4 released items, Steve has 2 released items, Jeremy has 3 released items.


If anyone can help with the code for this I'd greatly appreciate it!

Thanks!

18255

Paul_Hossler
02-05-2017, 04:12 PM
You could use a simple pivot table

18256

Chrisalisk
02-05-2017, 04:32 PM
Yeah, thought about that.. but back story to this is I have a macro button that once clicked will email to a group select information. I thus want the vba code to do the above so that I can link that information in with the email.

Cheers

Chris

mike7952
02-05-2017, 06:48 PM
Yeah, thought about that.. but back story to this is I have a macro button that once clicked will email to a group select information. I thus want the vba code to do the above so that I can link that information in with the email.

Cheers

Chris

So what is the output to look like? In you example workbook, Is this a true replica of your data structure? Is there more columns?

Chrisalisk
02-06-2017, 04:35 AM
Well output would look somewhat like the pivot data from Paul, but the data can't go in the doc as it would just make the document too complicated. I'm aiming to just fill an email with the data to show people how many released items they have. I guess for now it would be OK to just populate the doc with the data to solve this issue and then I'll just edit the code slightly to populate an email rather than onto the spreadsheet?

There are more columns yes but the info in it is sensitive that's why I've set up the example doc as that is a true representation of the workbook in its most simplistic form. There is a column stating released or draft, and a column with names of responsible parties in it.

mike7952
02-06-2017, 10:52 AM
How about this then. Adds a new workbook


Sub abc()
Const shNameOfYourSheet As String = "Sheet1"
Dim arr, key, i As Long

With Worksheets(shNameOfYourSheet)
arr = .Range("b4", .Cells(Rows.Count, "b").End(xlUp).Resize(, 5))
End With

With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
If arr(i, 1) = "Released" Then
If Not .exists(arr(i, 5)) Then
.Item(arr(i, 5)) = 1
Else
.Item(arr(i, 5)) = .Item(arr(i, 5)) + 1
End If
End If
Next
Workbooks.Add: i = 2
Cells(1).Resize(, 2) = [{"Name","Count"}]
For Each key In .keys
Cells(i, 1).Resize(, 2) = Array(key, .Item(key))
i = i + 1
Next
End With
End Sub

Chrisalisk
02-07-2017, 09:29 AM
How about this then. Adds a new workbook


Sub abc()
Const shNameOfYourSheet As String = "Sheet1"
Dim arr, key, i As Long

With Worksheets(shNameOfYourSheet)
arr = .Range("b4", .Cells(Rows.Count, "b").End(xlUp).Resize(, 5))
End With

With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
If arr(i, 1) = "Released" Then
If Not .exists(arr(i, 5)) Then
.Item(arr(i, 5)) = 1
Else
.Item(arr(i, 5)) = .Item(arr(i, 5)) + 1
End If
End If
Next
Workbooks.Add: i = 2
Cells(1).Resize(, 2) = [{"Name","Count"}]
For Each key In .keys
Cells(i, 1).Resize(, 2) = Array(key, .Item(key))
i = i + 1
Next
End With
End Sub



Yep, that works really well! Cheers!

Out of curiosity, how would someone recommend editing this to populate an email instead of a new workbook? Code to 'Output loop to a txt file' and then 'paste entire content of txt file into email body' or would there be a simpler method?

mike7952
02-07-2017, 03:06 PM
Yeah, thought about that.. but back story to this is I have a macro button that once clicked will email to a group select information. I thus want the vba code to do the above so that I can link that information in with the email.

Cheers

Chris

I don't know what email code you already have.

Chrisalisk
02-07-2017, 04:07 PM
I don't know what email code you already have.



Sub Send_Email_Using_VBA()

If Not Weekday(Date) = vbTuesday Then
MsgBox "It is not a Friday, email can only be sent out on a Friday"

Else

'-------------------Count Total Docs----------

Dim Total_no_Of_Released_Docs, Total_no_Of_Draft_Docs As Integer


Total_no_Of_Released_Docs = Application.WorksheetFunction.CountIf(Range("F12:F9999"), "Released")
Total_no_Of_Draft_Docs = Application.WorksheetFunction.CountIf(Range("F12:F9999"), "Draft")

' ------------------EMAIL SECTION----------------

Dim Email_Subject, Email_Send_From, Email_Send_To, _
Email_Cc, Email_Bcc, Email_Body As String

Dim Mail_Object, Mail_Single As Variant


Email_Subject = "Weekly Update - Documents for Review"


Email_Send_From = ""
'Set send_to to email a list of contact
Email_Send_To = Worksheets("Sheet1").Range("X5")
Email_Cc = ""
Email_Bcc = ""

'SET EMAIL CONTENTS

Email_Body = "All," & vbCrLf & _
vbCrLf & _
"Please see below for this week's update" & vbCrLf & _
vbCrLf & _
"Total no. of Released Docs = " & Total_no_Of_Released_Docs & vbCrLf & _
"Total no. of Draft Docs = " & Total_no_Of_Draft_Docs & vbCrLf & _
vbCrLf & _
"Number of Released Docs per Person:"& vbCrLf & _
*************INPUT DATA ON COUNT PER NAME HERE************



'Error resolution
On Error GoTo debugs

Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = Email_Subject
.To = Email_Send_To
.cc = Email_Cc
.BCC = Email_Bcc
.Body = Email_Body
.send
End With

debugs:
If Err.Description <> "" Then MsgBox Err.Description

End If
End Sub


This is the basic form but effectively just putting a little table matrix of the data you genreated in a new workbook into the Email body - location marked.

mike7952
02-07-2017, 07:34 PM
Give this a try


Sub Send_Email_Using_VBA()

If Not Weekday(Date) = vbTuesday Then
MsgBox "It is not a Friday, email can only be sent out on a Friday"

Else

'-------------------Count Total Docs----------

Dim Total_no_Of_Released_Docs, Total_no_Of_Draft_Docs As Integer


Total_no_Of_Released_Docs = Application.WorksheetFunction.CountIf(Range("F12:F9999"), "Released")
Total_no_Of_Draft_Docs = Application.WorksheetFunction.CountIf(Range("F12:F9999"), "Draft")

' ------------------EMAIL SECTION----------------

Dim Email_Subject, Email_Send_From, Email_Send_To, _
Email_Cc, Email_Bcc, Email_Body As String

Dim Mail_Object, Mail_Single As Variant
Dim Names_Counts As String

Names_Counts = GetNames_GetCounts

Email_Subject = "Weekly Update - Documents for Review"


Email_Send_From = ""
'Set send_to to email a list of contact
Email_Send_To = Worksheets("Sheet1").Range("X5")
Email_Cc = ""
Email_Bcc = ""

'SET EMAIL CONTENTS

Email_Body = "All," & vbCrLf & _
vbCrLf & _
"Please see below for this week's update" & vbCrLf & _
vbCrLf & _
"Total no. of Released Docs = " & Total_no_Of_Released_Docs & vbCrLf & _
"Total no. of Draft Docs = " & Total_no_Of_Draft_Docs & vbCrLf & _
vbCrLf & _
"Number of Released Docs per Person:" & vbCrLf & Names_Counts
'*************INPUT DATA ON COUNT PER NAME HERE************



'Error resolution
On Error GoTo debugs

Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = Email_Subject
.To = Email_Send_To
.cc = Email_Cc
.BCC = Email_Bcc
.Body = Email_Body
.send
End With

debugs:
If Err.Description <> "" Then MsgBox Err.Description

End If
End Sub
Function GetNames_GetCounts() As String
Const shNameOfYourSheet As String = "Sheet1"
Dim arr, key, i As Long
Dim sEmailCount As String
Dim sName As String * 20
Dim sCount As String


With Worksheets(shNameOfYourSheet)
arr = .Range("b4", .Cells(Rows.Count, "b").End(xlUp).Resize(, 5))
End With

With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
If arr(i, 1) = "Released" Then
If Not .exists(arr(i, 5)) Then
.Item(arr(i, 5)) = 1
Else
.Item(arr(i, 5)) = .Item(arr(i, 5)) + 1
End If
End If
Next
sName = "Name"
sCount = "Count"
sEmailCount = sName & sCount & vbNewLine
For Each key In .keys
sName = key
sCount = .Item(key)
sEmailCount = sEmailCount & sName & sCount & vbNewLine
Next
End With
GetNames_GetCounts = sEmailCount
End Function