Question

背景资料

以下是我正在使用的两张表：

工作表A（A-P列）： - 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（A-Z列）： - 与工作表A中的每个Loc_ID一起使用的缩略语

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

我的目标是完成两张纸之间的关系，并能够添加一个重新命名为首字母缩略词（即ABC）的新工作表，并从SHEET A中获取与该首字母缩略词相关的Loc_ID，如下所示表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")

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

背景资料

代码：

2 个答案: