How to loop through a range of cells?

Question

I have values in this "Sample Analysis Data" sheet in the range B2:B10.

For each cell in the range, the code looks for that value in the sheet "Meta Data". It then copies the cells in that row and pastes it in "Sample Analysis Data" (to the right of the searched value). This works for the value in B2.

I can't get it to move on to B3 and then B4 and such. It loops though and does the same thing again for B2.

What do I need to do to get it to loop to from B2 through to B10?
Along with this, how do I get it to go from B2 to the last entry in the column (as each data set I work with could have a different number of rows of data,) not just to B10?

Sub GetMetaData()

    Worksheets("Sample Analysis Data").Activate
    Range("B2").Select

    Dim srch As Range, cell As Variant
    Set srch = Range("B2:B10")

    For Each cell In srch
        Sheets("Meta Data").Activate

        Cells.Find(What:=cell, LookIn:=xlValues, LookAt:= _
          xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
          , SearchFormat:=False).Activate

        ActiveSheet.Cells(ActiveCell.Row, 1).Select
        Range(ActiveCell, ActiveCell.End(xlToRight).End(xlToRight)).Select

        Application.CutCopyMode = False
        Selection.Copy

        Sheets("Sample Analysis Data").Activate

        ActiveCell.Offset(0, 7).Select
        ActiveSheet.Paste

    Next cell
End Sub

If you haven't read it already, give this question a read. It will help you solve your problem. — BigBen

Emi Emi · Accepted Answer · 2019-10-31T21:04:59

Try this? Change the i=8 to however many cells you need to offset (you indicated B2:B10, which is 8)

Sub testcopy()

    Dim srch As Range, metarg As Range, rg As Range, pstrg As Range
    Dim i As Long
    Dim ws As Worksheet, ws2 As Worksheet

    Set ws = ThisWorkbook.Sheets("Sample Analysis Data")
    Set ws2 = ThisWorkbook.Sheets("Meta Data")

    Set metarg = ws2.Range("A1:A100") 'range that includes the key that you are searching in B2:B10

    Set srch = ws.Range("B1")  'i'm offsetting, so i'm going back one row
    For i = 1 To 8 'change 8 to how many cells to offset
        Set rg = metarg.Find(srch.Offset(i, 0).Value, LookIn:=xlValues, lookat:=xlWhole) 'find the value in meta sheet
        If Not rg Is Nothing Then
            Set pstrg = ws2.Range(rg, ws2.Cells(rg.Row, rg.End(xlToRight).Column))
            pstrg.Copy
            srch.Offset(i, 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End If
    Next i

    End Sub

How to loop through a range of cells?

1 Answers