选择并复制特定单元格

Question

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

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

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

样本数据

扫描：

Private Sub CommandButton1_Click()

row_number = 4
count_of_str = 0
Do
DoEvents
row_number = row_number + 1
item_in_review = Sheets("Sheet1").Range("H" & row_number)
    If InStr(item_in_review, "name") Then
      count_of_str = count_of_str + 1
    End If

Loop Until item_in_review = ""
MsgBox "the str occured: " & count_of_str & " times."
End Sub

Answer 1

利用Find / FindNext 方法

不完全清楚你的数据在哪一列。我假设标签name和contact在H，实际数据在I

另外，我假设每个name 都会有一个contact，并且没有包括任何检查。

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

Answer 2

未经测试：

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