Revise report output macro to new workbook, search additional sheet and add headers

[tsebastian03]

Hi All,

I have used the following macro to create a report based on criteria. Currently, it outputs the row results to a sheet labeled "Report". I need to revise the code to add some additional aspects.

1. I would like the output to be to a new workbook.

2. When the rows are outputted to a new sheet, I would like to have defined headers so the output starts in Row 2 and I can have the same header for all outputs. These headers are Row 1 in the sheet labeled "COM".

3. The macro as written only searches the sheet "HOTLINE" and returns the rows that have the search criteria "Unqualified Lead" in Column A. I would like for it to search 2 sheets: HOTLINE and WEBS for the same search criteria.

Could I get some help on how to revise the code to achieve this? The original code is below:

Sub UnqualifiedLeads()
'Updated 4-21-2020
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("HOTLINE").UsedRange.Rows.Count
J = Worksheets("Report").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Report").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("HOTLINE").Range("A1:A" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Unqualified Lead" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Report").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
MsgBox "Unqualified Lead Report Complete!", vbExclamation
Sheets("Report").Select
End Sub

 

[GWteB]

How about

Sub UnqualifiedLeads()

    Dim oWb         As Workbook
    Dim oWsDest     As Worksheet
    Dim oWsSource   As Worksheet
    Dim rngSrc      As Range
    Dim lRow        As Long
    Dim sStart      As String
    Dim c           As Range

    lRow = 1

    Application.ScreenUpdating = False

    ' create new workbook
    Set oWb = Application.Workbooks.Add

    ' determine destination sheet
    Set oWsDest = oWb.Sheets(1)

    ' place header on destination sheet
    ThisWorkbook.Sheets("COM").Rows(1).Copy Destination:=oWsDest.Rows(lRow)

    ' copy requested rows of requested sheets on destination sheet
    For Each oWsSource In ThisWorkbook.Worksheets

        '                       \/\/\/  \/\/
        If (CBool(InStr(LCase("|HOTLINE|WEBS|"), LCase("|" & oWsSource.Name & "|")))) Then
            Set rngSrc = oWsSource.UsedRange
            Set c = rngSrc.Find("Unqualified Lead")
            If Not c Is Nothing Then
                sStart = c.Address
                Do
                    lRow = lRow + 1
                    c.EntireRow.Copy Destination:=oWsDest.Rows(lRow)
                    Set c = rngSrc.FindNext(c)
                    If c Is Nothing Then Exit Do
                Loop While sStart <> c.Address
            End If
        End If
        Set c = Nothing
        Set rngSrc = Nothing

    Next oWsSource

    Set oWsDest = Nothing
    Set oWb = Nothing
    
    Application.ScreenUpdating = True

    MsgBox "Unqualified Lead Report Complete!", vbExclamation

End Sub

 

[tsebastian03]

How about

Sub UnqualifiedLeads()

    Dim oWb         As Workbook
    Dim oWsDest     As Worksheet
    Dim oWsSource   As Worksheet
    Dim rngSrc      As Range
    Dim lRow        As Long
    Dim sStart      As String
    Dim c           As Range

    lRow = 1

    Application.ScreenUpdating = False

    ' create new workbook
    Set oWb = Application.Workbooks.Add

    ' determine destination sheet
    Set oWsDest = oWb.Sheets(1)

    ' place header on destination sheet
    ThisWorkbook.Sheets("COM").Rows(1).Copy Destination:=oWsDest.Rows(lRow)

    ' copy requested rows of requested sheets on destination sheet
    For Each oWsSource In ThisWorkbook.Worksheets

        '                       \/\/\/  \/\/
        If (CBool(InStr(LCase("|HOTLINE|WEBS|"), LCase("|" & oWsSource.Name & "|")))) Then
            Set rngSrc = oWsSource.UsedRange
            Set c = rngSrc.Find("Unqualified Lead")
            If Not c Is Nothing Then
                sStart = c.Address
                Do
                    lRow = lRow + 1
                    c.EntireRow.Copy Destination:=oWsDest.Rows(lRow)
                    Set c = rngSrc.FindNext(c)
                    If c Is Nothing Then Exit Do
                Loop While sStart <> c.Address
            End If
        End If
        Set c = Nothing
        Set rngSrc = Nothing

    Next oWsSource

    Set oWsDest = Nothing
    Set oWb = Nothing
  
    Application.ScreenUpdating = True

    MsgBox "Unqualified Lead Report Complete!", vbExclamation

End Sub

That worked! If I could trouble you a bit further:
Instead of taking the header from COMS Row 1, could I take the Header from each WEBS and HOTLINE and have the output be in a new workbook but as two sheets labeled HOTLINE and WEBS.

Basically: the output to be in a new workbook with two sheets: HOTLINE and WEBS and use the headers from the original tabs for the outputted rows from each original sheet. Basically its like a summary report of the search criteria only. So the new workbook would have the same tabs and same header but just the searched results!

Thank you so so much for the assistance, I really appreciate it. I'm decent at simple macros but slowly developing my knowledge base.

 

[GWteB]

Okay, try this

Sub UnqualifiedLeads_r2()

    Dim oWsEmpty    As Worksheet
    Dim oWsSource   As Worksheet
    Dim oWsDest     As Worksheet
    Dim rngSrc      As Range
    Dim lRow        As Long
    Dim sStart      As String
    Dim c           As Range

    With Application

        .ScreenUpdating = False
        ' create new workbook
        Set oWsEmpty = .Workbooks.Add.Sheets(1)
        ' copy requested rows of requested sheets on destination sheet
        For Each oWsSource In ThisWorkbook.Worksheets
            With oWsSource
            '                           \/\/\/  \/\/
                If (CBool(InStr(LCase("|HOTLINE|WEBS|"), LCase("|" & .Name & "|")))) Then
                    lRow = 1
                    ' provide new worksheet
                    Set oWsDest = oWsEmpty.Parent.Worksheets.Add
                    ' rename newly added worksheet
                    oWsDest.Name = .Name
                    ' copy row with headings
                    .Rows(lRow).Copy Destination:=oWsDest.Rows(lRow)
                    ' set reference to used cells in column A to search in
                    Set rngSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, "A").End(xlUp))
                    ' search and when found: copy row
                    Set c = rngSrc.Find("Unqualified Lead")
                    If Not c Is Nothing Then
                        sStart = c.Address
                        Do
                            lRow = lRow + 1
                            c.EntireRow.Copy Destination:=oWsDest.Rows(lRow)
                            Set c = rngSrc.FindNext(c)
                            If c Is Nothing Then Exit Do
                        Loop While sStart <> c.Address
                        Set c = Nothing
                    End If
                    Set oWsDest = Nothing
                    Set rngSrc = Nothing
                End If

            End With
        Next oWsSource
        ' remove unused worksheet
        .DisplayAlerts = False
        oWsEmpty.Delete
        Set oWsEmpty = Nothing
        .DisplayAlerts = True

        .ScreenUpdating = True

    End With

    MsgBox "Unqualified Lead Report Complete!", vbExclamation

End Sub

 

[tsebastian03]

That works perfect! Thank you so much!

 

[GWteB]

You are welcome and thanks for letting me know.

 

[tsebastian03]

You are welcome and thanks for letting me know.

Hey! If I could trouble you about the search criteria. How can I make it so it searches for that exact text and not a partial match? I ask because I have criteria of unqualified lead and qualified lead, but if I put "qualified lead" and run the macro, it still returns the results for "unqualified lead" as well since technical the text is within that cell as well. So I just need the code tweaked so the text search is an exact match and not partial. Thanks in advance!!!!

 

[GWteB]

I see ... try amending the following line

Set c = rngSrc.Find("Qualified Lead", LookAt:=xlWhole)

 

[tsebastian03]

Perfect! Thanks again.