Sorting using Macro

Hi all, I have a requirement to sort on each item, if that item text is present in a cell.Please see the attached file. 'Reference' sheet has names of fruits. Now if we go to 'Results' sheet, ' T 'column, it has many fruits names separated by semi-colon. If we filter using "contains", for fruit, say , apple, it will give four results. So, all these four results should be copied(entire row) to another worksheet(name= apple), including the title, as shown done manually in 'Apple' worksheet. Similarly it should happen for other fruits also. Can this be automated, perhaps by using a macro... ? I use 2003 version.

Any help will be highly appreciated ...

Thanks in advance !

See attached file where I added this macro:

Sub macro1()
   Dim refSh As Worksheet
   Dim resSh As Worksheet
   Dim refLr As Long, resLr As LoadPictureConstants
   Dim resLc As Integer, r As Long
   Dim newSh As Worksheet, sh As Variant
   Dim fruitName As String, foundRows As Long
   
   Application.ScreenUpdating = False
   With ThisWorkbook
      Set refSh = .Sheets("reference")
      Set resSh = .Sheets("results")
      
      'remove filter from result sheet
      resSh.AutoFilterMode = False
      resLr = resSh.Cells(Rows.Count, "t").End(xlUp).Row
      resLc = resSh.Cells(1, Columns.Count).End(xlToLeft).Column
      
      'delete all sheets
      For Each sh In ThisWorkbook.Sheets
         Application.DisplayAlerts = False
         If sh.Name <> refSh.Name And sh.Name <> resSh.Name Then
            sh.Delete
         End If
         Application.DisplayAlerts = True
      Next
      
      'for each fruit
      resSh.Activate
      
      refLr = refSh.Cells(Rows.Count, 1).End(xlUp).Row
      For r = 2 To refLr
         fruitName = refSh.Cells(r, 2)
         resSh.Range("t:t").AutoFilter Field:=1, Criteria1:="=*" & fruitName & "*"
         foundRows = 0
         
         'get rows found
         On Error Resume Next
         foundRows = resSh.Range("t2:t" & resLr).SpecialCells(xlCellTypeVisible).Cells.Count
         On Error GoTo 0
         
         Set newSh = .Sheets.Add(, .Sheets(.Sheets.Count))
         If foundRows > 0 Then
            refSh.Cells(r, "c") = foundRows
            newSh.Name = fruitName & " (" & foundRows & ")"
            resSh.Cells(1, 1).Resize(resLr, resLc).Copy newSh.Cells(1, 1)
         Else
            newSh.Name = fruitName
         End If
      Next r
   End With
   resSh.AutoFilterMode = False
   refSh.Activate
   Application.ScreenUpdating = True
End Sub

Regards,
Antonio

Thanks a ton Antonio !!!!!.. Just one more.. it is working for first 19 rows of reference list as per my attached sheet.. however, can you make this work for the all the rows in reference sheet ? It is not always restricted to 19 .... Thanks once again...

The macro reads dynamically the number of rows in the Reference sheet, it's not fixed to 19 rows.
However tell me if you need I change something.

Regards,
Antonio

Hi Antonio, when I try to add more rows(upto 60, which is my actual requirement) it is returning an error(Error 400 ). I have attached the modified file for your reference; Thanks once again !!!

I checked my code and I've seen there were 2 times the same fruit name.
If you want I can modify the macro to skip double fruit name and avoid the error.

Regards,
Antonio