PDA

View Full Version : Create Report based on criteria match



Energizey
10-16-2018, 08:25 PM
Hi everyone,

Appreciate help with code I require to create a report based on one or more criteria being met.

I have source data in one worksheet and destination worksheet where I want the report generated. I have three cells were criteria can be selected, I need the code to work regardless of whether one or all three criteria cells contain fields - Criteria 1 = Employee Name C2, Criteria 2 = Modality C3, Criteria 3 = Department C4.

I need all rows from source worksheet columns A:W, to be copied and pasted to destination worksheet from Row 7 down if criteria is met. So far I have only tried to tackle code if a match is found to Criteria 1 Employee Name, but cannot get that to work. The code I have so far is as follows -


Sub ConsolidatePayroll_singlecriteria()
'1. declare and set variables
'2. clear old search results
'3. find records that match criteria and paste them to the report sheet
Dim datasheet As Worksheet 'where data is to be copied from
Dim reportsheet As Worksheet 'where data is pasted to
Dim employeename As String
Dim finalrow As Integer
Dim i As Integer 'row counter
'set variables
Set datasheet = Sheet7
Set reportsheet = Sheet11
employeename = reportsheet.Range("C2").Value
'clear old data from report sheet
reportsheet.Range("A7:V200").ClearContents 'adjust range to be cleared based upon size of data
'goto datasheet and start searching and copying
datasheet.Select
finalrow = Cells(Row.Count, 1).End(xlUp).Row
'loop through the rows to find the matching records
For i = 2 To finalrow
If Cells(i, 3) = employeename Then 'if column C matches the search name then copy all rows
Range(Cells(i, 1), Cells(i, 22)).Copy 'copy columns 1 to 22 (A to V)
reportsheet.Select 'go to report sheet
Range("A200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats ' find the first blank cell and paste row
datasheet.Select 'go back to the data sheet and continue searching
End If

Next i
reportsheet.Select 'this is so that the report sheet is selected when the procedure ends
Range("B2").Select
End Sub

Paul_Hossler
10-17-2018, 06:27 AM
Please use CODE tags by clicking the [#] icon and pasting the macro between

Can you post a small sample workbook?

However, the macro would probably look something like this




Option Explicit

Sub ConsolidatePayroll()
'1. declare and set variables
'2. clear old search results
'3. find records that match criteria and paste them to the report sheet
'I have source data in one worksheet and destination worksheet where I want the report generated.
'I have three cells were criteria can be selected, I need the code to work regardless of whether
'one or all three criteria cells contain fields
' Criteria 1 = Employee Name C2
' Criteria 2 = Modality C3
' Criteria 3 = Department C4.

Dim DataSheet As Worksheet 'where data is to be copied from
Dim ReportSheet As Worksheet 'where data is pasted to
Dim EmployeeName As String
Dim FinalRow As Long, i As Integer

'set variables
Set DataSheet = Sheet7
Set ReportSheet = Sheet11
EmployeeName = ReportSheet.Range("C2").Value
Modality = ReportSheet.Range("C3").Value
Department = ReportSheet.Range("C4").Value

'clear old data from report sheet
ReportSheet.Range("A7:V200").ClearContents 'adjust range to be cleared based upon size of data

'goto datasheet and start searching and copying
With DataSheet
FinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row

'loop through the rows to find the matching records
For i = 2 To FinalRow

If Len(EmployeeName) > 0 And .Cells(i, 3).Value <> EmployeeName Then GoTo GetNext
If Len(Modality) > 0 And .Cells(i, 4).Value <> Modality Then GoTo GetNext
If Len(Department) > 0 And .Cells(i, 5).Value <> Department Then GoTo GetNext

Range(.Cells(i, 1), .Cells(i, 22)).Copy 'copy columns 1 to 22 (A to V)
ReportSheet.Range("A200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats ' find the first blank cell and paste row
End If
GetNext:
Next i

ReportSheet.Select 'this is so that the report sheet is selected when the procedure ends

Range("B2").Select
End Sub







Also there were a few errors / typos in your macro. For example




finalrow = Cells(Row.Count, 1).End(xlUp).Row



should probably have been




finalrow = Cells(Rows.Count, 1).End(xlUp).Row

Energizey
10-17-2018, 03:02 PM
Thanks for your help Paul, grateful for your advice!!

I have attached a sample of what I am trying to achieve.

One thing that I omitted to say in my original post is that the user doesn't need to specify all three criteria. For example they may just want the report to meet the criteria Employee Name, or Employee Name and Modality. The purpose of the report is to ensure that we are budgeting correct number of hours for each Employee or Modality or Department. We have several clinics in the same city so one employee could work across more than one clinic or across more than one modality. We need to ensure that employee budget hours are no less than their contracted hours and that modality and Department hours are no less then our clinic opening hours.

Thank you

Paul_Hossler
10-17-2018, 04:37 PM
1. I understood the 1 or 2 or 3 criteria part. That was the purpose of the Len … > 0 part





If Len(EmployeeName) > 0 And .Cells(i, 3).Value <> EmployeeName Then GoTo GetNext
If Len(Modality) > 0 And .Cells(i, 4).Value <> Modality Then GoTo GetNext
If Len(Department) > 0 And .Cells(i, 5).Value <> Department Then GoTo GetNext



2. Having some data to play with makes it easier, and I did find some bugs in my first macro

3. I really did not like the way the C2, C3, or C4 dropdowns showed the same entry multiple times so I add a Worksheet_Activate event to the Payroll Report sheet to make 3 unique lists and use those




Option Explicit
Private Sub Worksheet_Activate()
Dim r As Range
Dim i As Long
Dim sName As String, sModality As String, sDept As String

With Sheet7.Cells(1, 1).CurrentRegion

sName = .Cells(2, 3).Value & ","
sModality = .Cells(2, 5).Value & ","
sDept = .Cells(2, 1).Value & ","

For i = 3 To .Rows.Count
If InStr(sName, .Cells(i, 3).Value) = 0 Then sName = sName & .Cells(i, 3).Value & ","
If InStr(sModality, .Cells(i, 5).Value) = 0 Then sModality = sModality & .Cells(i, 5).Value & ","
If InStr(sDept, .Cells(i, 1).Value) = 0 Then sDept = sDept & .Cells(i, 1).Value & ","
Next i

If Right(sName, 1) = "," Then sName = Left(sName, Len(sName) - 1)
If Right(sModality, 1) = "," Then sModality = Left(sModality, Len(sModality) - 1)
If Right(sDept, 1) = "," Then sDept = Left(sDept, Len(sDept) - 1)
End With

With Sheet11.Range("C2").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=sName
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = vbNullString
.ErrorTitle = vbNullString
.InputMessage = vbNullString
.ErrorMessage = vbNullString
.ShowInput = True
.ShowError = True
End With

With Sheet11.Range("C3").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=sModality
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = vbNullString
.ErrorTitle = vbNullString
.InputMessage = vbNullString
.ErrorMessage = vbNullString
.ShowInput = True
.ShowError = True
End With

With Sheet11.Range("C4").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=sDept
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = vbNullString
.ErrorTitle = vbNullString
.InputMessage = vbNullString
.ErrorMessage = vbNullString
.ShowInput = True
.ShowError = True
End With
End Sub




So here's some more to play with

Energizey
10-17-2018, 05:02 PM
Brilliant thank you very much!! I will have a play with that this afternoon and let you know how I get on.