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

背景信息

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

表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，如表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

我想这里可能有几个问题。 第一个是你的resize的声明。 如果我理解正确，你的大小总是覆盖第一行。 如果你包含相同的variables，你应该写入不同的范围，每个循环。 你能尝试这样的事吗？

 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的范围。 根据你的例子，它看起来像每个首字母缩略词列可以有多个值，但是当你寻找首字母缩写string，你只能看第一行。 您可能需要进一步调整以循环遍历每列中的所有值，但这至less应该让您朝着正确的方向前进：

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

Answer 2

熟悉SQL？

打开ABC工作表并添加一个Microsoft Query（数据function区，外部数据）

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，只需将ABCreplace为其他工作表的其他列名即可。 这将需要1分钟的上衣:)