Copy rows to another sheet if any cell in the row contains a certain word

Hello Thea,

See if this works?

First you need a macro that will filter the organs and copy them to its respective sheets.

Function CopyDiagnostic(nameSheet As String)

Dim lro As Long

lrow = Sheets("ALL").Cells(Rows.Count, 1).End(xlUp).Row

With Sheets("ALL")
    'apply filter for the data
    
    .Range("$A$1:$P$" & lrow).AutoFilter Field:=7, Criteria1:=UCase(nameSheet)
    
    Range("A1").CurrentRegion.Copy _
    Destination:=Sheets(nameSheet).Range("A1")
    Sheets(nameSheet).Cells.EntireColumn.AutoFit
    
    'remove the previous filter
    .Range("$A$1:$P$" & lrow).AutoFilter Field:=7
End With
  
End Function

and then a code to go through all the sheets pasting what was filtered.

Sub CopyDiagnosticMain()

Dim sh As Worksheet

Application.ScreenUpdating = False

'first lets make sure we have an autofilter applied in the mail sheet

If Sheets("ALL").AutoFilterMode = False Then
    Sheets("ALL").Range("A1").AutoFilter
End If


'go throu each one of the sheets
For Each sh In ThisWorkbook.Sheets
    If Not sh.Name = "ALL" Then
        Call CopyDiagnostic(sh.Name)
    End If
Next

'remove the autofilter
Sheets("ALL").Range("A1").AutoFilter

Application.ScreenUpdating = True

End Sub

The only code you have to run is the second one. Put them both in a same module.

I have attached a file for you to see. Attachment 262413

Originally Posted by fredlo2010

Hello Thea,

See if this works?

First you need a macro that will filter the organs and copy them to its respective sheets.

Function CopyDiagnostic(nameSheet As String)

Dim lro As Long

lrow = Sheets("ALL").Cells(Rows.Count, 1).End(xlUp).Row

With Sheets("ALL")
    'apply filter for the data
    
    .Range("$A$1:$P$" & lrow).AutoFilter Field:=7, Criteria1:=UCase(nameSheet)
    
    Range("A1").CurrentRegion.Copy _
    Destination:=Sheets(nameSheet).Range("A1")
    Sheets(nameSheet).Cells.EntireColumn.AutoFit
    
    'remove the previous filter
    .Range("$A$1:$P$" & lrow).AutoFilter Field:=7
End With
  
End Function

and then a code to go through all the sheets pasting what was filtered.

Sub CopyDiagnosticMain()

Dim sh As Worksheet

Application.ScreenUpdating = False

'first lets make sure we have an autofilter applied in the mail sheet

If Sheets("ALL").AutoFilterMode = False Then
    Sheets("ALL").Range("A1").AutoFilter
End If


'go throu each one of the sheets
For Each sh In ThisWorkbook.Sheets
    If Not sh.Name = "ALL" Then
        Call CopyDiagnostic(sh.Name)
    End If
Next

'remove the autofilter
Sheets("ALL").Range("A1").AutoFilter

Application.ScreenUpdating = True

End Sub

The only code you have to run is the second one. Put them both in a same module.

I have attached a file for you to see. Attachment 262413

I have one query though. I have noticed that some people with Thyroid problems in the master sheet don't appear in the Thyroid specific sheet. I am not sure if this is because the word 'Thyroid' doesn't appear in the first Diagnostics column (D1). Is there a way of getting patients with umbrella labels like that no matter what column they appear in, to appear in the respective organ sheet.

Thank you!

Thanks for the reply fredlo2010!

It works perfectly! You are a godsend, haha!

Appreciate it so much, this is going to save so much time!

you are right let me see how I can solve this .

Thea,

I think we got it this time.

this is the function

Private Function CopyDiagnostic(nameSheet As String)

Dim lro As Long
Dim lrowTarget As Long
Dim col As Long
Dim n As Long


lrow = Sheets("ALL").Cells(Rows.Count, 1).End(xlUp).Row
col = Sheets("All").Cells(1, Columns.Count).End(xlToLeft).Column

    With Sheets("ALL")
        'apply first filter filter for the data
        .Range("$A$1:$P$" & lrow).AutoFilter Field:=7, Criteria1:=UCase(nameSheet)
        Range("A1").CurrentRegion.Copy _
        Destination:=Sheets(nameSheet).Range("A1")
        Sheets(nameSheet).Cells.EntireColumn.AutoFit
        'remove the previous filter
        .Range("$A$1:$P$" & lrow).AutoFilter Field:=7
        
        
        'now all the other filters
        For n = 8 To col
        
            ' define the last row target
            lrowTarget = Sheets(nameSheet).Cells(Rows.Count, 1).End(xlUp).Row + 1
            
            'apply filter for the data
            .Range("$A$1:$P$" & lrow).AutoFilter Field:=n, Criteria1:=UCase(nameSheet)
            Range("A1").CurrentRegion.Offset(1, 0).Copy _
            Destination:=Sheets(nameSheet).Cells(lrowTarget, 1)
            Sheets(nameSheet).Cells.EntireColumn.AutoFit
            'remove the previous filter
            .Range("$A$1:$P$" & lrow).AutoFilter Field:=n
        Next n
        
    End With
      
End Function

and the main code

Sub CopyDiagnosticMain()

Dim sh As Worksheet

Application.ScreenUpdating = False

'first lets make sure we have an autofilter applied in the mail sheet

If Sheets("ALL").AutoFilterMode = False Then
    Sheets("ALL").Range("A1").AutoFilter
End If


'go throu each one of the sheets
For Each sh In ThisWorkbook.Sheets
    If Not sh.Name = "ALL" Then
        Call CopyDiagnostic(sh.Name)
    End If
Next

'remove the autofilter
Sheets("ALL").Range("A1").AutoFilter

Application.ScreenUpdating = True

End Sub

Thanks

Thanks so much! It works really well. I appreciate it so much. I don't understand the code at all but so long as it works. If I had more time, I'd love to be able to learn more about it as I'm sure it would save me so much time in all of my excel projects!

Thanks again

I am glad it helped you