VBA Copy whole rows based on find hits

[Davavo]

Hi,
could really use some help with this. (hopefully not as dumb as question as last time!

I am trying to write a macro that will search through a load of sheets for a value in column L, and if it finds that value, copy the whole row (and repeat for all non blank rows in sheet)
I will need to loop this through sheets too, but for now, i am just having trouble copying the whole row.
I can find the right cell, and report the address, but I am not sure of the correct method of copying the row. (would prefer to restrict it to defined columns rather than the whole row)

Any help much appreciated.

Sub CCAutoWrite()

    'Purpose: Find in column 'L' all instances of strings containing "ZHAN".  Copy whole row of each insatnce to another sheet.  Loop for all instances on sheet.  Loop for all sheets in workbook.


    Dim CC_Test As Workbook
    
    Dim Source As Worksheet 'since will expand this macro to loop through sheets
    Dim Target As Worksheet 'target will be the same
    
    Dim lastRow As Long 'name of row on which value was found
    Dim TLastRow As Long 'name of last non blank row of target sheet so that results can be pasted underneath
    
    Dim strSearch As String 'define name of search operation
    
    Dim aCell As Range 'name of range in which the string was found
    Dim copyrng As Range 'name of range to be copied
   
    
    On Error GoTo Whoa 'error exit
    
    Set Source = Sheets("May") 'set for testing prior to coding a loop
    Set Target = Sheets("TargetSheet") 'set for testing prior to coding a loop
    
    TLastRow = Target.Cells(Rows.Count, 1).End(xlUp).Row 'Set lastrow as the bottommost row containing values in the target sheet
    
    
    With Source
    
    lastRow = Source.Range("L" & .Rows.Count).End(xlUp).Row 'this makes lastRow the last non empty row on the source sheet so delimits the search area
    strSearch = "ZHAN"  'defines the search term
    
    'set the value of aCell
    Set aCell = Source.Range("L1:L" & lastRow).Find(what:=strSearch, LookIn:=xlValues, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)
    
   
   [B] Set copyrng = ****************************************   'how to identify the row on which the value was found?[/B]
    
    'if something is found
    If Not aCell Is Nothing Then
    MsgBox "Value Found in Cell " & aCell.Address 'create a messagebox with address to confirm just for testing during coding
    
   
    copyrng.Copy
    'aCell.EntireRow.Copy 'would be better to restrict to A:Z
    Target.Range("A" & TLastRow).Offset(1, 0).PasteSpecial Paste:=xlPasteValues 'pastes to the first blank row
   
    
    End If


    
    Exit Sub
    
Whoa:


    MsgBox Err.Description
    End With
    
End Sub

 

[Fluff]

No column headers.

Then what's row 7

Try

Sub Davavo()
   Dim Ws As Worksheet, Trgtws As Worksheet
   Dim UsdRws As Long
   
   Set Trgtws = Sheets("TargetSheet")
   For Each Ws In Worksheets
      If Ws.Name <> Trgtws.Name Then
         UsdRws = Ws.Range("L" & Rows.Count).End(xlUp).Row
         Ws.Range("A7:L" & UsdRws).AutoFilter 12, "*zhan*"
         Ws.AutoFilter.Range.Offset(1).EntireRow.Copy Trgtws.Range("L" & Rows.Count).End(xlUp).Offset(1, -11)
         Ws.AutoFilterMode = False
      End If
   Next Ws
End Sub

 

[Davavo]

Then what's row 7

Try

Sub Davavo()
   Dim Ws As Worksheet, Trgtws As Worksheet
   Dim UsdRws As Long
   
   Set Trgtws = Sheets("TargetSheet")
   For Each Ws In Worksheets
      If Ws.Name <> Trgtws.Name Then
         UsdRws = Ws.Range("L" & Rows.Count).End(xlUp).Row
         Ws.Range("A7:L" & UsdRws).AutoFilter 12, "*zhan*"
         Ws.AutoFilter.Range.Offset(1).EntireRow.Copy Trgtws.Range("L" & Rows.Count).End(xlUp).Offset(1, -11)
         Ws.AutoFilterMode = False
      End If
   Next Ws
End Sub

Ah, right, see what you mean. Headers. I thought they would be at the top!

That doesn't quite work. It doesn't collect all of the entries, or it overwrites them. It is also writing some into the K column, when all the rest go into L.

 

[Fluff]

That is probably down to the merged cells.
Unfortunately just unmerging them at the start of the code probably wont help as the values may be in the wrong columns.

 

[Davavo]

it actually does that if i unmerge manually prior to running the script.

 

[Davavo]

Hidden column k!

Sub Davavo3()   Dim Ws As Worksheet, Trgtws As Worksheet
   Dim UsdRws As Long
   
   Set Trgtws = Sheets("TargetSheet")
   For Each Ws In Worksheets
      If Ws.Name <> Trgtws.Name Then
      Ws.Columns("k").Hidden = False
      
         UsdRws = Ws.Range("L" & Rows.Count).End(xlUp).Row
         Ws.Range("A7:L" & UsdRws).AutoFilter 12, "*zhan*"
         Ws.AutoFilter.Range.Offset(1).EntireRow.Copy Trgtws.Range("L" & Rows.Count).End(xlUp).Offset(1, -11)
         Ws.AutoFilterMode = False
      End If
   Next Ws
End Sub

Works!

 

[Fluff]

Glad you sorted it & thanks for the feedback

 

[Davavo]

That works without even unmerging the evil in advance Fluff.
Cant thank you enough for your help with this.

Very much appreciated!