Как я могу сделать этот суб-цикл через ряд ячеек правильно

Question

У меня есть значения в этом листе «Данные анализа образца» в диапазоне B2: B10. Для каждой ячейки в диапазоне код должен искать это значение на листе «Метаданные». Затем он копирует ячейки в этой строке и вставляет их в «Данные анализа образца» (справа от искомого значения). Все это прекрасно работает для значения в B2. Тем не менее, я не могу заставить его перейти к B3 ... а затем B4 и тому подобное. Он просто зацикливается и делает то же самое снова для B2.

• Что мне нужно сделать, чтобы получить цикл от B2 до B10?

• Наряду с этим, как мне получитьчтобы перейти от B2 к последней записи в столбце (поскольку каждый набор данных, с которым я работаю, может иметь различное количество строк данных, а не только 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

Answer 1

Попробуйте это? Измените значение i = 8 на любое количество ячеек, которые необходимо сместить (вы указали B2: B10, что равно 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