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]

How about

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

 

[Davavo]

thanks for you reply Fluff
This does something but i am not sure what.
It seems to return blanks with formatting to the target sheet. The Source sheet contains sheets hits but the formatting makes me think that the code is returning hits from sheets that do have matching values but it either is pasting only formatting or the values are being overwritten and the formatting is not being overwritten.

I don't really understand your code, but it makes me suspect that i didn't express my problem well enough.
I want to look down column L, find all of the cells that contain that contain "Zhan", for instance Zhan123 309, or ZHAN320 902 etc etc
I want to copy the entire row where these are found and paste to sheet TargetSheet.

I was then going to try to make that macro loop through several (unknown number of) sheets in the source workbook.

Thanks again! I spent hours trying to make this work and your code looks like it does it could do it in a few lines !

 

[Fluff]

Do all sheets have a header row in row 1?
Also did you get any error messages?

 

[Fluff]

Another point.
Does col A always have data in all sheets?

 

[Davavo]

Do all sheets have a header row in row 1?
Also did you get any error messages?

No error messages.

It isnt a table, its a receipt. (receipts). Basically, I am trying to make a table out of a bunch of credit card logs. Cell A1 is always filled with a string "Transaction log"

Number of entries varies in column L varies.

Another point.
Does col A always have data in all sheets?

Yes. But as i mentioned, its not in tabular form.
Column A contains dates, if there are entries. And above the dates, always has the word "date" in column A row 7 and "Cardholders name: **bla bla **" in column A row 5.

Thanks again.

 

[Fluff]

Ok, try this

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("A1: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]

Ok, try this

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("A1: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

Thanks, that works pretty well.
If Trgws is a blank sheet, each ws seems to overwrite the previous one, but thats ok, as when it is pasting to a table, it works perfectly, and it should be a table it pastes to.
One problem is merged cells in the source.
I tried unmerge but that seems to stop the auto-filter from working properly. The output isnt restricted to zhan anyway and is 3000 rows rather than 18.

Sub Davavo2()   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("A1:L" & UsdRws).UnMerge
         Ws.Range("A1: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

and this

Sub Davavo2()   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.Cells.UnMerge
         UsdRws = Ws.Range("L" & Rows.Count).End(xlUp).Row
         Ws.Range("A1: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

but both produce very large outputs that are not filtered.
Would an index/match kind of operation on the L column work more reliably?

Something else i realised is that for each ws I have to collect the value in cell A5 and paste to each row= returned for that sheet. Sorry for not specifying that initially.

 

[Fluff]

Firstly I would advise removing all the merged cells, they are an abomination & should be avoided like the plague.
Do you have a row that contains column headers? If so what row is it?

 

[Davavo]

Firstly I would advise removing all the merged cells, they are an abomination & should be avoided like the plague.

I know, but no choice i am afraid. Actually, i could just leave instructions to remove all the merge cells before using it.

Do you have a row that contains column headers? If so what row is it?

No column headers.


Example....

https://imgur.com/kpL1T8g

also, it would be accessed as an external workbook.