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

Question

背景資料

這是我正在使用的兩張表：

表A（列AP）： - Loc_ID及其信息

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

表B（列AZ）： - 與表A中的每個Loc_ID一起使用的縮略語

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

我的目標是完成兩個工作表之間的關系，並能夠添加一個重命名為首字母縮略詞（即ABC）的新工作表，並從SHEET A中獲取與該首字母縮略詞相關的Loc_ID，如SHEET B所示新表：ABC。

我已經完成了我的目標，但我遇到的問題是只添加了一行指定的位置。

例如，只有這一行顯示在新工作表中：“ABC”

123456     ABCX - Sales Park   0012       Joe       Schmo

有沒有辦法可以添加與首字母縮略詞相關的同一個Loc_ID的多行？

碼：

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

熟悉SQL？

打開ABC工作表並添加Microsoft Query（數據功能區，外部數據）

ABC工作表的示例SQL：

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

您還可以將我的SQL加載項用於excel： http ： //www.analystcave.com/excel-tools/excel-sql-add-in-free/ 。 基於上面的SQL，只需將ABC替換為其他工作表的其他列名。 這需要1分鍾的上衣:)

Answer 2

我想這里可能有幾個問題。 第一個是在你的調整大小聲明中。 如果我理解正確，您將調整大小以始終覆蓋第一行。 如果包含相同的變量，則應在每個循環中寫入不同的范圍。 你能嘗試這樣的東西嗎？

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

第二個問題似乎是你如何設置你的acroymns的范圍。 根據您的示例，看起來每個首字母縮寫詞列都可以有多個值，但是當您查找縮寫詞字符串時，您只能查看第一行。 您可能需要進一步調整以循環遍歷每列中的所有值，但這至少應該讓您朝着正確的方向前進：

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