根据另一个工作表中单元格的值从字符串中提取文本

Question

我有一本带有一系列工作表的工作簿，我需要运行一个代码来解析数据。

我有一个工作表，其中包含“代码”列表，而另一个工作表中的单元格将包含一串代码。

我正在尝试创建一个宏，该宏允许我引用sheet1 A1中的代码，然后浏览sheet2中的B：B并复制该行（如果代码出现在字符串中）

我是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

在没有看到电子表格的情况下，我假设您的所有“代码”都列在sheet1的A列中，并且所有这些代码字符串也列在B列的sheet2中。我的代码允许u从Column中的sheet1中查找每个字符串工作表B。一旦找到，它将从第二行开始粘贴到Sheet3中。

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

Answer 3

这应该工作，只需在运行后删除sheet3上的重复项即可。这是一个双循环，其中，对于工作表2的B列中的每个单元格，宏将检查来自工作表1的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