Create Report based on criteria match

[Energizey]

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]

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]

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]

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]

Brilliant thank you very much!! I will have a play with that this afternoon and let you know how I get on.