Using excel VBA, how do you copy multiple rows of the same value into a new sheet?

Background information

Here are two sheets that I work with:

Sheet A (Columns AP): - Loc_ID and its information

Loc_ID     Loc_Name            Emp_ID     First     Last
123456     ABCX - Sales Park   0012       Joe       Schmo
123456     ABCX - Sales Park   0019       John      Smith
123456     ABCX - Sales Park   0089       Gary      Hammond
654321     ABCX - Sales Force  0192       Tom       Lenardo
654321     ABCX - Sales Force  0165       Tim       Hamilton

      

        
        
        
      

    

Sheet B (Columns AZ): - Acronyms that go with each Loc_ID from sheet A

ABC      CBA      ZAH      XYZ
123456   532453   453853   366542
654321   123875   483286   546435
         568723   K45524   214354

      

        
        
        
      

    

My goal was to make the relationship between the two sheets and be able to add to a new sheet that is renamed to an abbreviation (i.e. ABC) and grab the Loc_IDs from SHEET A that refer to that abbreviation as shown in SHEET B to the new sheet: ABC.

I completed my task, but the problem is that only one row is being added from the specified locations.

For example, only this line appears in a new sheet: "ABC"

123456     ABCX - Sales Park   0012       Joe       Schmo

      

        
        
        
      

    

Is there a way to add multiple lines of the same Loc_ID referring to an abbreviation?

code:

Sub Macro5()
Dim shtA As Worksheet   'variable represents Sheet A
Dim shtB As Worksheet   'variable represents Sheet B
Dim shtNew As Worksheet 'variable to hold the "new" sheet for each acronym
Dim acronyms As Range 'range to define the list of acronyms
Dim cl As Range     'cell iterator for each acronmym
Dim r As Integer    'iterator, counts the number of locatiosn in each acronym
'Dim valueToFind As String 'holds the location that we're trying to Find
'Dim foundRange As Range   'the result of the .Find() method

'## Assign our worksheets variables
Set shtA = Worksheets("Leavers")
Set shtB = Worksheets("Tables")

'## Assign the list of acronmys in Sheet B
Set acronyms = shtB.Range("B1:Z1")

'## Begin our loop over each acronym:
For Each cl In acronyms.Cells
    '## Add a new sheet for each acronym:
    Set shtNew = Sheets.Add(After:=Sheets(Sheets.Count))
    shtNew.Name = cl.Value

    r = 1 'start each acronym at "1"

    '## Loop over each row, which contain the location IDs
    '   assumes that there is no additional data below the location IDs
    '   this terminates at the first empty cell in each column
    Do While Not cl.Offset(r).Value = ""

        '## Define the value we're looking for:
        valueToFind = cl.Offset(r).Value

        'Search in "SHEET A", Column A
        With shtA.Range("A:A")
            '## Assign the result of the Find method to a range variable:
            Set foundRange = .Find(What:=valueToFind, _
                                   After:=.Range("A1"), _
                                   LookIn:=xlFormulas, _
                                   LookAt:=xlWhole, _
                                   SearchOrder:=xlByRows, _
                                   SearchDirection:=xlNext, _
                                   MatchCase:=False, _
                                   SearchFormat:=False)
            End With


        '## Make sure the value was found:
        If foundRange Is Nothing Then
            MsgBox valueToFind & " not found!"
        Else:
            '## Resize the foundRange to include columns A:P
            Set foundRange = foundRange.Resize(1, 16)

            '## Copy & paste to the new worksheet for this acronym
            foundRange.Copy Destination:=shtNew.Cells(r, 1)
        r = r + 1
        End If
    Loop
Next
End Sub