查找某个数据，找到后把符合条件数据的一行复制到另外一个地方

在Excel中批量查找并复制特定数据

最新推荐文章于 2024-12-29 00:14:52 发布

转载最新推荐文章于 2024-12-29 00:14:52 发布 · 4.6k 阅读

文章标签：

#function #string #工作

VBA 专栏收录该内容

7 篇文章

订阅专栏

本文介绍了一个在Excel工作表中根据指定条件批量查找数据并将其复制到目标区域的方法，通过自定义宏实现自动化操作，适用于数据管理与整理。

在一个列表中复制相关数据到另一个列表
本程序的功能是，根据单元格I1中的值，在单元格区域A1:D11中的B列进行查找，每次找到相应的值，就将该单元格所在区域的行数据复制到以单元格G3(该单元格命名为found)开始的区域中。原数据如下图2所示。

图2：原始数据
点击工作表中的“查找”按钮，运行后的结果如下图3所示。

图3：运行后的结果
源程序代码清单及相关说明如下：

Option Explicit
Sub FindSample2()
  Dim ws As Worksheet
  Dim rgSearchIn As Range
  Dim rgFound As Range
  Dim sFirstFound As String
  Dim bContinue As Boolean
 
  ReSetFoundList '初始化要复制的列表区域
  Set ws = ThisWorkbook.Worksheets("sheet1")
  bContinue = True
  Set rgSearchIn = GetSearchRange(ws) '获取查找区域
  
  '设置查找参数
  Set rgFound = rgSearchIn.Find(what:=ws.Range("I1").Value, _
             LookIn:=xlValues, LookAt:=xlWhole)
 
  '获取第一个满足条件的单元格地址,作为结束循环的条件
  If Not rgFound Is Nothing Then sFirstFound = rgFound.Address
 
  Do Until rgFound Is Nothing Or Not bContinue
    CopyItem rgFound
    Set rgFound = rgSearchIn.FindNext(rgFound)
    '判断循环是否中止
    If rgFound.Address = sFirstFound Then bContinue = False
  Loop
 
  Set rgSearchIn = Nothing
  Set rgFound = Nothing
  Set ws = Nothing
End Sub
 
'获取查找区域,即B列中的"部位"单元格区域
Private Function GetSearchRange(ws As Worksheet) As Range
  Dim lLastRow As Long
  lLastRow = ws.Cells(65536, 1).End(xlUp).Row
  Set GetSearchRange = ws.Range(ws.Cells(1, 2), ws.Cells(lLastRow, 2))
End Function
 
'复制查找到的数据到found区域
Private Sub CopyItem(rgItem As Range)
  Dim rgDestination As Range
  Dim rgEntireItem As Range
 
  '获取在查找区域中的整行数据
  Set rgEntireItem = rgItem.Offset(0, -1)
  Set rgEntireItem = rgEntireItem.Resize(1, 4)
 
  Set rgDestination = rgItem.Parent.Range("found")
  '定位要复制到的found区域的第一行
  If IsEmpty(rgDestination.Offset(1, 0)) Then
    Set rgDestination = rgDestination.Offset(1, 0)
  Else
    Set rgDestination = rgDestination.End(xlDown).Offset(1, 0)
  End If
 
  '复制找到的数据到found区域
  rgEntireItem.Copy rgDestination
 
  Set rgDestination = Nothing
  Set rgEntireItem = Nothing
End Sub
 
'初始化要复制到的区域(found区域)
Private Sub ReSetFoundList()
  Dim ws As Worksheet
  Dim lLastRow As Long
  Dim rgTopLeft As Range
  Dim rgBottomRight As Range
 
  Set ws = ThisWorkbook.Worksheets("sheet1")
  Set rgTopLeft = ws.Range("found").Offset(1, 0)
  lLastRow = ws.Range("found").End(xlDown).Row
  Set rgBottomRight = ws.Cells(lLastRow, rgTopLeft.Offset(0, 3).Column)
 
  ws.Range(rgTopLeft, rgBottomRight).ClearContents
 
  Set rgTopLeft = Nothing
  Set rgBottomRight = Nothing
  Set ws = Nothing
End Sub