найти текст и скопировать соседнюю ячейку на другой лист

Question

Мне нужна помощь.Мне нужно выполнить поиск в моем листе и найти определенное слово («вещества»), а затем скопировать значение в столбцах ячейки 2 на другой лист.

Например, в Листе 1, если «вещества» были найдены в A4, скопируйте значение из C4 и вставьте в Лист2 под последней заполненной строкой.Мне нужно продолжать делать это для всего листа.«Вещества» не появляются последовательно, но всегда в столбце A (т.е. первое вхождение может быть A4, ext может быть в A16).

Вот что у меня есть:

Dim Cell, cRange As Range
    Set cRange = Sheets("Sheet1").Range("A1:A75")
    For Each Cell In cRange
    FindCounter = 0

    If Cell.Value = "Substances" Then
        FindCounter = FindCounter + 1
        Sheets("Sheet1").Cell.Value(0, 2).Copy
        Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
    End If
    Next

    Application.ScreenUpdating = True

Answer 1

Попробуй это. Поиск более эффективен, чем зацикливание (по причинам, которые я никогда полностью не понимал).

Sub x()

Dim rFind As Range, s As String

With Sheets("Sheet1").Range("A1:A75")
    Set rFind = .Find(What:="Substances", Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
    If Not rFind Is Nothing Then
        s = rFind.Address
        Do
            Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).Value = rFind.Offset(, 2).Value
            Set rFind = .FindNext(rFind)
         Loop While rFind.Address <> s
    End If
End With

End Sub

Answer 2

Альтернативное использование для цикла:

Sub Copy()

    Dim i As Long
    Dim lRow1 As Long, lRow2 As Long
    Dim ws1 As Worksheet, ws2 As Worksheet

    'set worksheets
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")

    'set last row to search for substances
    lRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
    'start for loop
    For i = 1 To lRow1
        If ws1.Range("A" & i).Value = "Substances" Then
            'assuming you want to paste into column A on sheet 2
            'adjust as you need to
            lRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row + 1

            ws2.Range("A" & lRow2).Value = ws1.Range("A" & i).Offset(0, 2).Value
        End If
    Next
    'clear objects
    Set ws1 = Nothing
    Set ws2 = Nothing

End Sub