搜索信息，并从另一个表格添加

Question

图像

图像1这是人们将要满足的格式，示例搜索了716

图像2，然后是716格式，应该在其中粘贴信息如下(它已经有信息(

图3添加信息应像这样最终出现(添加下面的信息而不是重写它(

我有一个代码，在搜索另一个表格中搜索一个值，我想复制原始纸在另一个单元格中的波纹管，但是我想oly复制具有信息的内容。然后返回找到的值，并使用信息粘贴最后一个单元格。

由于表Bancos有更多信息，因此代码替换了其中的信息，相反，我希望它在左侧搜索最后未使用的单元格4 bellow 1，并在下面开始搜索10行，并粘贴信息在BU工作表上。

这是针对一种新格式，它始终搜索单元格" C3"，并添加" B7：C19"

的信息

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 "No se encontró, desea agregar la partida: " & Worksheets("BU").Range("C3").Value
            End If
        End With
    End If
End Sub

无错误msgs

Answer 1

好吧，我更改了几行，如下所示，我希望这能解决您的问题。

Private Sub C1_Click()
Dim Partida As String
Dim Rng As Range, r1 As Range, r2 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
                Set r2 = Rng.Offset(4, -1).End(xlDown)
                If r2.Row > 19 Then
                    Set r2 = Rng.Offset(4, -1)
                Else
                    Set r2 = r2.Offset(1)
                End If
                For Each r1 In Worksheets("Bu").Range("B7:B19")
                    If Len(r1) > 0 Then
                        r2.Resize(, 2).Value = r1.Resize(, 2).Value
                        Set r2 = r2.Offset(1)
                    End If
                Next r1
            Else
                MsgBox "No se encontró, desea agregar la partida: " & Worksheets("BU").Range("C3").Value
            End If
        End With
    End If
End Sub