Excel 选择并复制特定单元格

我有一个excel工作表，我想根据它们的值选择一些单元格，然后使用VBA将这些单元格复制到另一个工作表中

我有一段代码，它遍历所有excel表格，搜索特定值，然后返回这些单元格的总数

• 我需要立即复制H列中具有值“name”和“contact”的单元格，并将所有这些值复制到同一工作簿中的sheet2
• 然后我需要复制姓名和联系人旁边的单元格
• 最终结果是一个新表，其中包含两列name和contact，每列下都包含属于它的每个name和contact的值

样本数据

扫描： 未经测试：

Private Sub CommandButton1_Click()
    Dim count_of_str As Long
    Dim c as Range, d As Range

    count_of_str = 0

    Set c = Sheets("Sheet1").Range("H4")  'cell to check
    Set d = Sheets("Sheet2").Range("A2")  'destination to copy to

    Do While Len(c.Value) > 0

        If InStr(c.Value, "name") > 0 Then
            count_of_str = count_of_str + 1
            c.Copy d
            Set d = d.Offset(1, 0)  'next destination row
        End If

        Set c = c.Offset(1, 0) 'next cell to check

    Loop 

    MsgBox "the str occured: " & count_of_str & " times."

End Sub

---

使用

Find

/

FindNext

方法

还不完全清楚您的数据所在的列。我假设标签

name

和

contact

在

H

中，实际数据在

I

此外，我假设每个

姓名

都会有一个

联系人

，并且没有包含任何检查

Sub Demo()
    Dim row_number As Long, count_of_str As Long
    Dim rToSearch  As Range, rFound As Range, rng As Range
    Dim strSearchTerm As String
    Dim FirstAddr As String
    Dim ws As Worksheet, rDest As Range

    Dim cl As Range, ar As Range
    strSearchTerm = "name"

    With Sheets("Sheet1")
        Set rToSearch = .Range(.Cells(5, 8), .Cells(.Rows.Count, 8).End(xlUp))
    End With

    Set rng = rToSearch.Find( _
      What:=strSearchTerm, _
      After:=rToSearch.Cells(rToSearch.Cells.Count), _
      LookIn:=xlValues, _
      LookAt:=xlPart, _
      SearchOrder:=xlByRows, _
      SearchDirection:=xlNext, _
      MatchCase:=False, _
      SearchFormat:=False)

    If Not rng Is Nothing Then
        FirstAddr = rng.Address
        Do
            count_of_str = count_of_str + 1
            If rFound Is Nothing Then
                Set rFound = rng.Offset(0, 1)
            Else
                Set rFound = Union(rFound, rng.Offset(0, 1))
            End If
            Set rng = rToSearch.FindNext(rng)
        Loop Until rng.Address = FirstAddr
    End If

    MsgBox "the str occured: " & count_of_str & " times."
    ' rFound now refers to all found cells

    ' Copy to somewhere
    Set ws = Worksheets("YourDestinationSheet")     '<~~Update as required
    Set rDest = ws.Range("YourDestinationRange")    '<~~Update as required
    If Not rFound Is Nothing Then
        rFound.Copy rDest                           '<~~ copy names
        rFound.Offset(1, 0).Copy rDest.Offset(0, 1) '<~~ copy contacts
    End If

    ' Process found cells
    ' eg
    If Not rFound Is Nothing Then
        For Each ar In rFound.Areas
        For Each cl In ar.Cells
            Debug.Print cl.Address
        Next cl, ar
    End If
End Sub

子演示（）
将行数变长，将列数变长
Dim RTO搜索范围、rFound范围、rng范围
Dim strSearchTerm作为字符串
Dim FirstAddr作为字符串
将ws作为工作表进行尺寸标注，将rDest作为范围
尺寸cl作为范围，ar作为范围
strearchterm=“名称”
附页（“第1页”）
设置rToSearch=.Range（.Cells（5,8），.Cells（.Rows.Count，8）.End（xlUp））
以
设置rng=rToSearch.Find（_
什么：=strSearchTerm_
之后：=rToSearch.Cells（rToSearch.Cells.Count）_
LookIn:=xlValues_
看：=xlPart_
搜索顺序：=xlByRows_
SearchDirection:=xlNext_
MatchCase:=假_
SearchFormat:=False）
如果不是，那么rng什么都不是
FirstAddr=rng.Address
做
_str的_计数=_str的_计数+1
如果rFound不算什么，那么
设置rFound=rng.偏移量（0,1）
其他的
Set rFound=联合（rFound，rng.Offset（0,1））
如果结束
设置rng=rToSearch.FindNext（rng）
循环直到rng.Address=FirstAddr
如果结束
MsgBox“str发生次数：“&count\u次”
'rFound现在指所有找到的单元格
“抄送到某个地方
Set ws=Worksheets（“YourDestinationSheet”）'您需要添加更多关于应该复制哪些单元格（仅是H列中的单元格？）以及它们应该复制到哪里的详细信息。我将编辑我的帖子并添加一些详细信息您的代码工作非常出色现在我想复制值“name”旁边的单元格，因此我需要首先搜索该值“name”然后复制它旁边的单元格这是我问题的完美解决方案，但它还没有完成，因为我还需要复制到另一张表，包含其他值的单元格是“contact”“如何在代码中添加此选项？您应该能够自己扩展此代码。如果需要更多帮助，请添加一些显示源图纸和复制图纸的示例数据。（注意将此编辑到你的Q中）我编辑了我的帖子并添加了2张图片，以澄清我需要什么查看编辑帖子我有一些重复名称，其中每个重复名称中的一个第一次显示时没有联系人，但第二次显示时有联系人。。。我可以检查一下他们的名字是否没有联系人吗？不要复制它？@devleb当然可以，为什么不试一试呢
Sub Demo()
    Dim row_number As Long, count_of_str As Long
    Dim rToSearch  As Range, rFound As Range, rng As Range
    Dim strSearchTerm As String
    Dim FirstAddr As String
    Dim ws As Worksheet, rDest As Range

    Dim cl As Range, ar As Range
    strSearchTerm = "name"

    With Sheets("Sheet1")
        Set rToSearch = .Range(.Cells(5, 8), .Cells(.Rows.Count, 8).End(xlUp))
    End With

    Set rng = rToSearch.Find( _
      What:=strSearchTerm, _
      After:=rToSearch.Cells(rToSearch.Cells.Count), _
      LookIn:=xlValues, _
      LookAt:=xlPart, _
      SearchOrder:=xlByRows, _
      SearchDirection:=xlNext, _
      MatchCase:=False, _
      SearchFormat:=False)

    If Not rng Is Nothing Then
        FirstAddr = rng.Address
        Do
            count_of_str = count_of_str + 1
            If rFound Is Nothing Then
                Set rFound = rng.Offset(0, 1)
            Else
                Set rFound = Union(rFound, rng.Offset(0, 1))
            End If
            Set rng = rToSearch.FindNext(rng)
        Loop Until rng.Address = FirstAddr
    End If

    MsgBox "the str occured: " & count_of_str & " times."
    ' rFound now refers to all found cells

    ' Copy to somewhere
    Set ws = Worksheets("YourDestinationSheet")     '<~~Update as required
    Set rDest = ws.Range("YourDestinationRange")    '<~~Update as required
    If Not rFound Is Nothing Then
        rFound.Copy rDest                           '<~~ copy names
        rFound.Offset(1, 0).Copy rDest.Offset(0, 1) '<~~ copy contacts
    End If

    ' Process found cells
    ' eg
    If Not rFound Is Nothing Then
        For Each ar In rFound.Areas
        For Each cl In ar.Cells
            Debug.Print cl.Address
        Next cl, ar
    End If
End Sub