Question

我有一个代码旨在： 1）使用搜索框从表中查找名称 2）将名称的行中的单元格复制到另一个工作表上 3）这应该适用于与此名称相关联的表中的所有条目。

代码示例：

Sub Printout()
Dim LR2 As Long
Dim c As Variant
Dim txt As Variant

c = InputBox("Enter Last Name")
txt = CStr(c)
Sheets("B").Select
Sheets("B").Range("K3").Value = txt

Sheets("A").Select
Sheets("A").Columns(2).Find(What:=txt, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Activate
LR2 = Sheets("A").Cells(Rows.Count, "a").End(xlUp).Row
Sheets("A").Range(Cells(ActiveCell.Row, 2), Cells(LR2, 10)).Select
Selection.Copy Destination:=Sheets("B").Range("A2:J2")


End Sub

问题：目前，代码不只是从搜索框输入中复制特定名称，还会在名称下复制所有条目。即如果“约翰逊”是第3,6和11条，我希望这三行的第2列到第10列。目前它找到了第一个条目，似乎复制了它下面的第2列到第10列中的所有内容。有人可以帮我解决这个代码问题，以便我可以做到我想要的吗？

提前致谢！

Answer 1

这是我最好的猜测

Sub Printout()

Dim LR2 As Long
Dim c As Variant
Dim txt As Variant
Dim r As Range
Dim s As String

c = InputBox("Enter Last Name")
txt = CStr(c)

Sheets("B").Range("K3").Value = txt

With Sheets("A")
    Set r = .Columns(2).Find(What:=txt, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
    If Not r Is Nothing Then
        s = r.Address
        Do
            LR2 = Sheets("B").Cells(Rows.Count, "a").End(xlUp).Row
            .Range(.Cells(r.Row, 2), .Cells(r.Row, 10)).Copy Destination:=Sheets("B").Range("A" & LR2)
            Set r = .Columns(2).FindNext(r)
        Loop While r.Address <> s
    End If
End With

End Sub

Answer 2

使用不是由您创建的代码有时会出现问题。在您的情况下，您要选择并复制您在第2列中找到的单元格。

如果你看一下这段代码并稍微编辑一下，你就能做到。

Option Explicit
Option Private Module

Sub Printout()

    Dim txt         As Variant
    Dim rngUnion    As Range
    Dim rngCell     As Range

    txt = "vi"

    With ActiveSheet
        For Each rngCell In .Range(.Cells(1, 1), .Cells(9, 1))
            If InStr(1, rngCell, txt) Then
                If rngUnion Is Nothing Then
                    Set rngUnion = .Range(.Cells(rngCell.Row, 2), .Cells(rngCell.Row, 5))
                Else
                    Set rngUnion = Union(rngUnion, .Range(.Cells(rngCell.Row, 2), .Cells(rngCell.Row, 5)))
                End If
            End If
        Next rngCell
    End With

    rngUnion.Select

End Sub

您的ActiveSheet应该是这样的：

代码的作用：

它循环通过从A1到A9的单元格。
如果在其中一个单元格中找到vi，则会将同一行的4个单元格添加到联合中 - rngUnion
最后它选择了一个联盟，只是为了向你展示它是哪一个。您可以复制选择或复制范围，而无需选择它。

祝你好运，玩得开心！

Answer 3

这应该是你所追求的。品尝季节，但它会做你想要的

Private Sub derp()
    Dim this As String
    this = InputBox("Enter Last Name")
    Dim rng As Range
    Dim rcell As Range
    Dim lastrow As Long
    Dim that As Variant

    lastrow = ThisWorkbook.Sheets("Sheet3").UsedRange.Rows.Count
    Set rng = ThisWorkbook.Sheets("Sheet2").Range("A1:a40")
    For Each rcell In rng.Cells
        If rcell.Value <> vbNullString Then
            If rcell.Value = this Then
                that = ThisWorkbook.Sheets("Sheet2").Range("A" & rcell.Row & ":H" & rcell.Row)
                ThisWorkbook.Sheets("Sheet3").Range("A" & lastrow & ":H" & lastrow).Value2 = that
                lastrow = lastrow + 1
            End If
        End If
    Next rcell
End Sub

根据“名称”（查找功能）vba从表中复制特定条目

3 个答案: