Извлечение текста из строки на основе значения ячейки в другом листе

Question

У меня есть рабочая книга с серией листов, которые мне нужны, чтобы запустить код для разрешения данных.

У меня есть один лист со списком «кодов» и другой лист с ячейками, которые будут содержать строку кодов.

Я пытаюсь создать макрос, который позволяет мне ссылаться на код в sheet1 A1, а затем просматривать B: B в sheet2 и копировать строку, если код появляется в строке

Я новичок в VBA и несколько раз пытался погуглить, но мне не повезло.

Редактировать:

Мне удалось получить что-то, что копирует данные, ноКажется, есть проблема в цикле For, поскольку копируются все строки, а не только совпадающие строки.Код ниже.

Private Sub CommandButton1_Click()

    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("MASTER LIST").UsedRange.Rows.Count
    J = Worksheets("VALIDATED LIST").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("VALIDATED LIST").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("MASTER LIST").Range("E1:E" & I)
    On Error Resume Next
    Application.ScreenUpdating = True

    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = InStr(Worksheets("MASTER LIST").Range("E1:E" & I).Value, Worksheets("TRANSPOSED DATA NO SPACES").Range("B1:B" & J)) > 1 Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("VALIDATED LIST").Range("A" & J + 1)
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Дальнейшее редактирование:

Я хочу иметь возможность использовать список кодов объектов и искать их в основном списке.

Если код VBA находит код функции в строках в основном списке, то мне нужно скопировать строку и вставить ее в чистый лист, который будет вызыватьсяпроверенный список.

Answer 1

Sub look_up_copy()
Dim last_row As Integer
Dim cell As Range
Dim Cells As Range

last_row = ThisWorkbook.Worksheets(2).Cells(ThisWorkbook.Worksheets(2).Rows.Count, "B").End(xlUp).Row
Set Cells = ThisWorkbook.Worksheets(2).Range("B1:B" & last_row)

For Each cell In Cells:
    If cell.Value = ThisWorkbook.Worksheets(1).Range("A1").Value Then
        cell.EntireRow.Copy
    End If
Next cell
End Sub

Вы ничего не сказали о желании вставить, но если вы это сделаете, просто вставьте его после строки копирования.

Answer 2

это должно работать, просто удалите дубликаты на sheet3 после запуска.Это двойной цикл, в котором для каждой ячейки в столбце B листа 2 макрос проверяет все значения из столбца sheet1, столбец A. В конце вы увидите повторяющиеся строки, но это не имеет значения, верно?все, что вам нужно, это удалить дубликаты

Sub IvanAceRows()

Dim cell2 As Range, cells2 As Range, cell1 As Range, cells1 As Range
Dim lastrow2 As Long, lastrow1 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Long, ii As Long, iii As Long

Set ws1 = Worksheets("USAGE CODES")
Set ws2 = Worksheets("MASTER LIST")
Set ws3 = Worksheets("VALIDATED LIST")

lastrow1 = ws1.cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = ws2.cells(Rows.Count, 2).End(xlUp).Row

Set cells1 = ws1.Range("A1:A" & lastrow1)
Set cells2 = ws2.Range("B1:B" & lastrow2)

iii = 1

For ii = 1 To lastrow2

    For i = 1 To lastrow1

            If InStr(1, ws2.cells(ii, 2), ws1.cells(i, 1)) <> 0 Then
                ws2.cells(ii, 2).EntireRow.Copy
                ws3.Activate
                ws3.cells(iii, 1).Select
                Selection.PasteSpecial
                iii = iii + 1
            End If

    Next i

Next ii

End Sub

Answer 3

Не видя вашу электронную таблицу, я предположил, что все ваши «коды» перечислены в столбце A в sheet1, и все эти строки кода также находятся в sheet2 в столбце B. Мой код позволяет вам найти каждую строку из sheet1 в столбцеБ листа2.Найденный файл будет вставлен в Sheet3, начиная со 2-го ряда.

Sub IvanfindsRow()

Dim i As Long
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim Code As String
Dim search As Range


lastrow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row

Worksheets("Sheet3").Range("A1").Select
For i = 1 To lastrow1

Code = Worksheets("Sheet1").Cells(i, 1).Value
Set search = Worksheets("Sheet2").Range("B1:B22").Find(what:=Code, lookat:=xlWhole)
        If Not search Is Nothing Then
            search.EntireRow.Copy
            ActiveCell.Offset(1, 0).Select
            Selection.PasteSpecial
            Else 'do nothing
        End If

Next i

Application.CutCopyMode = False


End Sub