Loop Copy a tables data into 1 cell, then Copy and paste the results into another table

Question

Below, I have the code which will copy data from Cells E3 to F3 into the next empty cell in column H.

Private Sub CommandButton1_Click()

    Application.ScreenUpdating = False

    Dim copySheet As Worksheet
    Dim pasteSheet As Worksheet

    Set copySheet = Worksheets("Sheet1")

    copySheet.Range("e3:f3").Copy
    copySheet.Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

The way my sheet is set up is as follows:

1) I have my data in cells B3 to C7

Person | Value
Alan   |   1
Dave   |   4
Fred   |   5
Perry  |   6
Ted    |   2

2) In cell E3 I have the input cell for where you put the name of the person and in F3 I have a vlookup which returns the value attached to the persons name.

3) What I need to happen is I need the code to loop through the names of the people from cells B3 to B7 until it reaches a blank cell, so first of all put the name of the person in cells B3 into cell E3, then copy this data from cells E3:F3 into another table.

4) What I should come out with is a clone of the data I had in the first data table. My actual excel sheet I am working on is a bit more complicated than this but if I can get code that does this it will give me a base to start from.

Any help would be much appreciated!

What have you tried? There must be countless examples on the web of for-each loops. Then you are just placing the value of B in E and copying E and F (the code for which you already have). — SJR
I have tried a few things but the main part I'm struggling on is the copying the data in cell B3 into cell E3 then looping back to copy cell B4 into cell E3 @SJR — tom bannister

SJR SJR · Accepted Answer · 2017-04-03T12:30:51

Here is an outline loop which should get you started. I'm not exactly clear on where everything is located so the sheets may not be right.

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim r As Range

Set copySheet = Worksheets("Sheet1")

With copySheet
    For Each r In .Range("B3", .Range("B" & Rows.Count).End(xlUp))
        If Len(r) > 0 Then
            .Range("E3").Value = r.Value
            .Range("E3").Resize(, 2).Copy
            .Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next r
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Loop Copy a tables data into 1 cell, then Copy and paste the results into another table

1 Answers