VBA Excel-根据用户输入将单元格值和相关行放入另一个工作表中

Question

全部-

我对 VBA 很陌生，我真的需要帮助。我有一个名为 Sheet 1 的工作表，看起来像这样（这是从中复制数据的地方）

和另一个看起来像这样的工作表（Sheet2）（这是数据将被复制到的位置）。注意顺序和上面的不一样

当用户在诸如“Paris”之类的地方键入时，我希望它复制所有与“Paris”相对应的值，并且它是关联的行。所以最终结果应该是这样的

这是我到目前为止的代码。现在，我可以根据用户输入提取所有相应的值，但我无法终生弄清楚如何获取关联的行。请帮忙！任何意见都将受到高度赞赏。

Dim x As String
Dim K As Long
Dim ct As Variant
Dim r As Range
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
x = Application.InputBox("Please Enter Place")
w1.Activate
K = 3
For Each r In Intersect(Range("C3:C3" & a), ActiveSheet.UsedRange)
ct = r.Value
If InStr(ct, x) > 0 And ct <> "" Then
r.Copy w2.Cells(K, 1)
K = K + 1
w2.Activate
End If
Next r
End Sub

Answer 1

将整个范围分配给一个数组以便更快地循环，然后一旦数组找到与您的输入字符串匹配的值，将值重写到您的第二张表。

Sub test()

    Dim ws1 As Worksheet, ws2 As Worksheet, wsArr()
    set ws1 = thisworkbook.worksheets("Sheet1")
    set ws2 = thisworkbook.worksheets("Sheet2")

    With ws1
        wsArr = .Range(.Cells(3, 1), .Cells(LastRow(ws1), 4)).Value
    End With

    Dim findStr As String
    findStr = InputBox("Please Enter Place")

    Dim i As Long, r as long
    Application.ScreenUpdating = False
    With ws2
        .Range("A3:D3").Value = array("Place", "Name", "Thing", "Animal")
        For i = LBound(wsArr) To UBound(wsArr)
            If wsArr(i, 3) = findStr Then
                r = LastRow(ws2) + 1
                .Cells(r, 1) = wsArr(i, 3)
                .Cells(r, 2) = wsArr(i, 1)
                .Cells(r, 3) = wsArr(i, 2)
                .Cells(r, 4) = wsArr(i, 4)
            End If
        Next
    End With
    Application.ScreenUpdating = True

End Sub

Function LastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long
    With ws
        LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
    End With
End Function

为了获得更好的性能，请考虑使用COUNTIF() 来计算您范围内出现findStr 的次数 - 这样您就可以将此值用于ReDim 一个新数组以写入匹配项在那里，然后将数组一次性写入Sheet2。