Поиск последней информации в диапазоне для копирования и вставки

Question

У меня есть код, который ищет значение в другом шетте, после поиска я хочу скопировать то, что на оригинальном листе ниже, в другие ячейки, но я хочу скопировать только то, что содержит информацию.Затем вернитесь к найденному значению и вставьте ниже последнюю ячейку с информацией.

В примере кода было найдено partida.value в листах ("bancos") cell = H6 Я хочу скопировать информацию в Sheets ("Bu ") B7: C19 и его должны получить приклеенные сильфоны (" bancos ") G13: h13

Private Sub C1_Click()
    Dim Partida As String
    Dim Rng As Range


    Partida = Worksheets("BU").Range("c3").Value
    If Trim(Partida) <> "" Then
        With Sheets("Bancos").Rows("6:6")
            Set Rng = .Find(What:=Partida, after:=.Cells(.Cells.Count), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
            If Not Rng Is Nothing Then
                Worksheets("Bu").Activate
                ActiveSheet.Range("b7:c19").Select
                'i want to copy only the filled cells in the range (b7:c19); the filled cells in b and c
                Selection.Copy
                Application.Goto Rng, True

                'I want to paste in the last cells with information within the right and below cells from the "rng" found in cells G and H
            Else
                MsgBox "Not found"
            End If
        End With
    End If

End Sub

Нет ошибок msg tho

Answer 1

Можете ли вы попробовать это. Это не проверено, но должно вас как минимум приблизить.

Private Sub C1_Click()

Dim Partida As String
Dim Rng As Range, r1 As Range, r As Long, c As Long

Partida = Worksheets("BU").Range("c3").Value

If Trim(Partida) <> "" Then
    With Sheets("Bancos").Rows("6:6")
        Set Rng = .Find(What:=Partida, after:=.Cells(.Cells.Count), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
        If Not Rng Is Nothing Then
            r = Rng.Row + 4
            c = Rng.Column - 1
            For Each r1 In Worksheets("Bu").Range("b7:c19")
                If Len(r1) > 0 Then
                    .Cells(r, c + r1.Column - 2).Value = r1.Value
                    r = r + 1
                End If
            Next r1
        Else
            MsgBox "Not found"
        End If
    End With
End If

End Sub