Copy range to other sheet depending on entry in cell

[RutgerdV]

Hello,

I recently discovered VBA.
I want to write values froms cells C4:C10 to another sheet, depending on the number given in C2.
On the first worksheet (ws1)
[TABLE="width: 128"]
<tbody>[TR]
[TD="width: 64"]Number:[/TD]
[TD="width: 64, align: right"]2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Value1[/TD]
[TD="align: right"]7[/TD]
[/TR]
[TR]
[TD]Value2[/TD]
[TD="align: right"]6[/TD]
[/TR]
[TR]
[TD]Value3[/TD]
[TD="align: right"]5[/TD]
[/TR]
[TR]
[TD]Value4[/TD]
[TD="align: right"]4[/TD]
[/TR]
[TR]
[TD]Value5[/TD]
[TD="align: right"]3[/TD]
[/TR]
[TR]
[TD]Value6[/TD]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD]Value7[/TD]
[TD="align: right"]1[/TD]
[/TR]
</tbody>[/TABLE]

On the next worksheet (ws2), I have number 1 to 10. If the number in the first row is the same as given in C2, then the values (C4:10) need to be copied in the cells below that number.
[TABLE="width: 704"]
<tbody>[TR]
[TD="width: 64"][TABLE="width: 704"]
<tbody>[TR]
[TD="width: 64"][/TD]
[TD="width: 64, align: right"]1[/TD]
[TD="width: 64, align: right"]2[/TD]
[TD="width: 64, align: right"]3[/TD]
[TD="width: 64, align: right"]4[/TD]
[TD="width: 64, align: right"]5[/TD]
[TD="width: 64, align: right"]6[/TD]
[TD="width: 64, align: right"]7[/TD]
[TD="width: 64, align: right"]8[/TD]
[TD="width: 64, align: right"]9[/TD]
[TD="width: 64, align: right"]10[/TD]
[/TR]
[TR]
[TD]Value1[/TD]
[TD][/TD]
[TD="align: right"]7[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Value2[/TD]
[TD][/TD]
[TD="align: right"]6[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Value3[/TD]
[TD][/TD]
[TD="align: right"]5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Value4[/TD]
[TD][/TD]
[TD="align: right"]4[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Value5[/TD]
[TD][/TD]
[TD="align: right"]3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Value6[/TD]
[TD][/TD]
[TD="align: right"]2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Value7[/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD="width: 64, align: right"][/TD]
[TD="width: 64, align: right"][/TD]
[TD="width: 64, align: right"][/TD]
[TD="width: 64, align: right"][/TD]
[TD="width: 64, align: right"][/TD]
[TD="width: 64, align: right"][/TD]
[TD="width: 64, align: right"][/TD]
[TD="width: 64, align: right"][/TD]
[TD="width: 64, align: right"][/TD]
[TD="width: 64, align: right"][/TD]
[/TR]
</tbody>[/TABLE]

I already got a code to find the the same number:

Private Sub CommandButton1_Click()
Dim FindString As String
Dim Rng As Range
FindString = Sheets("ws1").Range("c2").Value
If Trim(FindString) <> "" Then
With Sheets("ws2").Range("B1:K1")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub

Many thanks!

 

[JackDanIce]

Welcome to the board. Try:

Private Sub CommandButton1_Click()

    Dim str     As String
    Dim arr()   As Variant

    Dim ws1     As Worksheet
    Dim ws2     As Worksheet
    
    Set ws1 = Sheets("ws1")
    Set ws2 = Sheets("ws2")
    
    Dim rng     As Range
    
    With ws1
        str = Trim$(.Range("C2").value)
        arr = .Range("C4:C10").value
    End With
    
    Application.ScreenUpdating = False
    
    If LenB(str) > 0 Then
        With ws2.Cells(1, 2).Resize(, 10)
            Set rng = .find(str, .Cells(.Cells.count), xlValues, xlWhole)
            If Not rng Is Nothing Then rng.Offset(1).Resize(UBound(arr, 1)).value = arr
        End With
    End If
    
    Application.ScreenUpdating = True
    
    Set rng = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Erase arr
    
End Sub