VBA Loop: Find text in sheet1 and copy to sheet2, then loop to next or exit if blank or specific text.

[invasivedoc]

Hi
I am relatively new to VBA. I need to find a text string (STRING1), then copy the row below (range A:D) to sheet2, then continue to copy rows until either a blank cell or a specific text string (STRING2).
Can you help?
Thank you in advance

 

[mumps]

Insert "Phone" in cell D1 to replace "Column 4" and "Phone2" in cell J1 to replace "Column 10". There may be a more efficient way but try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim i As Long, dic As Object, phone1 As Long, phone2 As Long, workers As Long, positions As Variant, arr() As Variant
    Dim v1 As Variant, v2 As Variant, lRow As Long, lRow2 As Long, x As Long, pos As String, val As String
    phone1 = Rows(1).Find("Phone", LookIn:=xlValues, lookat:=xlPart, SearchDirection:=xlNext).Column
    phone2 = Rows(1).Find("Phone", LookIn:=xlValues, lookat:=xlPart, SearchDirection:=xlPrevious).Column
    workers = Rows(4).Find("Workers", LookIn:=xlValues, lookat:=xlPart, SearchDirection:=xlNext).Column
    lRow = Columns(1).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lRow2 = Columns(workers).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    positions = Array("CEO", "VPs", "Senior manager", "Junior manager", "Managers group", "Workers group")
    v1 = Range("A4", Range("A" & Rows.Count).End(xlUp)).Resize(, phone1).Value
    v2 = Range(Cells(4, workers), Cells(lRow2, workers)).Resize(, phone2 - phone1).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        val = v1(i, 1)
        If val Like "Managers group*" Then
            pos = val
        Else
            If Not IsError(Application.Match(val, positions, 0)) And val <> "" Then
                pos = val
            End If
        End If
        If val <> "" And InStr(val, " ") = 0 Then
            If IsError(Application.Match(val, positions, 0)) Then
                dic.Add val, v1(i, phone1) & "|" & pos
            End If
        Else
            If val <> "" Then
                If IsError(Application.Match(Split(val, " ")(0) & " " & Split(val, " ")(1), positions, 0)) Then
                    dic.Add val, v1(i, phone1) & "|" & pos
                End If
            End If
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        val = v2(i, 1)
        If val Like "Workers group*" Then
            pos = val
        Else
            If Not IsError(Application.Match(val, positions, 0)) And val <> "" Then
                pos = val
            End If
        End If
        If val <> "" And InStr(val, " ") = 0 Then
            If IsError(Application.Match(val, positions, 0)) Then
                dic.Add val, v2(i, phone2 - phone1) & "|" & pos
            End If
        Else
            If val <> "" Then
                If IsError(Application.Match(Split(val, " ")(0) & " " & Split(val, " ")(1), positions, 0)) Then
                    dic.Add val, v2(i, phone2 - phone1) & "|" & pos
                End If
            End If
        End If
    Next i
    With Sheets("Sheet2")
        .Range("A1").Resize(, 3).Value = Array("FullName", "Phone", "Position")
        .Range("A2").Resize(dic.Count).Value = Application.Transpose(dic.keys)
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("B2").Resize(dic.Count).Value = Application.Transpose(dic.items)
        v1 = .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).Value
    End With
    ReDim arr(1 To lRow - 1, 1 To 2)
    For i = LBound(v1) To UBound(v1)
        x = x + 1
        arr(x, 1) = Split(v1(i, 1), "|")(0)
        arr(x, 2) = Split(v1(i, 1), "|")(1)
    Next i
    Sheets("Sheet2").Range("B2").Resize(x, 2) = arr
    Application.ScreenUpdating = True
End Sub