Creating list based on 3 criteria

You could use this macro:

Sub Macro1()
   Dim sh1 As Worksheet
   Dim sh2 As Worksheet
   Dim lastRow As Long, r As Long, myTest As String
   Dim myNum As String, sh2Row As Long
   
   Set sh1 = ThisWorkbook.Sheets("sheet1")
   Set sh2 = ThisWorkbook.Sheets("sheet2")
   
   sh2.Cells.ClearContents
   
   lastRow = sh1.Cells(Rows.Count, "a").End(xlUp).Row
 
   sh2Row = 1
   For r = 1 To lastRow
      If sh1.Cells(r, 1) <> myNum Then
         myTest = "..."
         myNum = sh1.Cells(r, 1)
      End If
      Mid(myTest, Asc(sh1.Cells(r, 2)) - 64, 1) = " "

      If InStr(myTest, ".") = 0 Then
         sh1.Range(r - 2 & ":" & r).Copy sh2.Cells(sh2Row, 1)
         sh2Row = sh2Row + 3
      End If
   Next r
End Sub

Regards,
Antonio

Hi,

Thats works perfectly - thanks.

How can I get this to work if I change the values in row B? For example all the A's are "Mouse", all the B's are "Cat" and all the C's are "Dog".

Thanks again.

You could try with this macro (you can put B values in any order and the match is not case sensitive):

Sub Macro1()
   Dim sh1 As Worksheet
   Dim sh2 As Worksheet
   Dim lastRow As Long, r As Long, myTest As String
   Dim myNum As String, sh2Row As Long
   
   Set sh1 = ThisWorkbook.Sheets("sheet1")
   Set sh2 = ThisWorkbook.Sheets("sheet2")
   
   sh2.Cells.ClearContents
   
   lastRow = sh1.Cells(Rows.Count, "a").End(xlUp).Row
 
   sh2Row = 1
   For r = 1 To lastRow
      If sh1.Cells(r, 1) <> myNum Then
         myTest = "Mouse,Cat,Dog"
         myNum = sh1.Cells(r, 1)
      End If
      myTest = Replace(LCase(myTest), LCase(sh1.Cells(r, 2)), "")

      If myTest = ",," Then
         sh1.Range(r - 2 & ":" & r).Copy sh2.Cells(sh2Row, 1)
         sh2Row = sh2Row + 3
      End If
   Next r
End Sub

Regards,
Antonio

Antonio,

Again, that works perfectly. I have thought of one final change, if you have any suggesions...?

Currently, the value in column A must have mouse, cat, and dog in column B before it is copied to Sheet2. It would be good if the column A figure figure went to Sheet2 if it only has mouse as well - as per the example attached.

This is the last change - honestly

Thanks so much.

You could use this code:

Sub Macro1()
   Dim sh1 As Worksheet
   Dim sh2 As Worksheet
   Dim lastRow As Long, r As Long, myTest As String
   Dim myNum As String, sh2Row As Long, startRow As Long
   
   Set sh1 = ThisWorkbook.Sheets("sheet1")
   Set sh2 = ThisWorkbook.Sheets("sheet2")
   
   sh2.Cells.ClearContents
   
   lastRow = sh1.Cells(Rows.Count, "a").End(xlUp).Row
 
   sh2Row = 1
   For r = 1 To lastRow + 1
      If sh1.Cells(r, 1) <> myNum Then
         If myNum <> "" And myTest = "" Then
            sh1.Range(startRow & ":" & r - 1).Copy sh2.Cells(sh2Row, 1)
            sh2Row = sh2Row + r - startRow
         End If
         myTest = "Mouse"
         myNum = sh1.Cells(r, 1)
         startRow = r
      End If
      myTest = Replace(LCase(myTest), LCase(sh1.Cells(r, 2)), "")
 
   Next r
End Sub

Regards,
Antonio

Thats perfect. Thanks for your time and help