使用excel VBA，如何将同一值的多行复制到新工作表中？

Question

Background Information

Here are two Sheets I am working 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 accomplish the relationship between the two sheets and be able to add in a new sheet that is renamed as the acronym (ie, ABC), and grab the Loc_ID's from SHEET A that pertain to that acronym as shown in SHEET B into the new sheet: ABC.

I have accomplished my goal, but the problem I have is that there is only one row of the specified locations being added.

For example, only this row is showing up in the new sheet: "ABC"

123456     ABCX - Sales Park   0012       Joe       Schmo

Is there a way I can add multiple rows of the same Loc_ID that pertain to the acronym?

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

Answer 1

Familiar with SQL?

Open the ABC worksheet and add a Microsoft Query (Data ribbon, External data)

An example SQL for the ABC worksheet:

SELECT * FROM [S1$] AS S1 WHERE S1.Loc_ID in (SELECT ABC FROM [S2$])

You can also use my SQL Add-In for excel: http://www.analystcave.com/excel-tools/excel-sql-add-in-free/ . Based on the SQL above simply replace ABC with the other column names for the other worksheets. This will take 1 min tops :)

Answer 2

I think there may be a couple issues here. The first is in your resize statement. If I understand correctly, you're resizing to always overwrite the first row. If you incorporate the same variable, you should write to a different range each loop through. Can you try something like this?

Else:
    '## Resize the foundRange to include columns A:P
    Set foundRange = foundRange.Resize(r, 16) /*change the 1st parameter*/

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

The second issue appears to be with how you set the range for your acroymns. Based on your example, it looks like each acronymn column can have multiple values, however when you look for acronymn strings, you only look in the first row. You may need to tweak this further to loop over all values in each column but this should at least get you moving in the right direction:

Set acronyms = shtB.Range("B:Z")