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]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[invasivedoc]

Thank you for your kind response. I have enclosed a screenshot of what I have:

and I want to create a list that I am able to import into Outlook. However, the number of VPs, senior managers, junior managers, managers and workers change every month. So, I thought that I needed to find the column VPs, select all before a blank cell, and then copy them to the second sheet. Furthermore, you can see that there is no blank cell between Junior managers and Managers so in this case the find needs to select all before "Managers". Finally, that not all names are in column A-C, but also in E-H.

Can you help?
Thank you in advance.
Kind regards,
KW

 

[mumps]

Please note the array values in red. Change these values to suit your needs.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim v1 As Variant, v2 As Variant, i As Long, dic As Object
    positions = Array("CEO", "VPs", "Senior manager", "Junior manager", "Managers", "Workers")
    v1 = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value
    v2 = Range("E2", Range("E" & Rows.Count).End(xlUp)).Resize(, 3).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If IsError(Application.Match(v1(i, 1), positions, 0)) And v1(i, 1) <> "" Then
            dic.Add v1(i, 1), v1(i, 3)
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If IsError(Application.Match(v2(i, 1), positions, 0)) And v2(i, 1) <> "" Then
            dic.Add v2(i, 1), v2(i, 3)
        End If
    Next i
    With Sheets("Sheet2")
        .Range("A1") = "FullName"
        .Range("B1") = "Phone"
        .Range("A2").Resize(dic.Count, 2).Value = Application.Transpose(Array(dic.keys, dic.items))
    End With
    Application.ScreenUpdating = True
End Sub

 

[invasivedoc]

@mumps—Thank you so much. This is exactly what I need. However, I need to tweak it slightly since sometimes the phone number is one column to the right and sometimes three or four columns to the right. I am unsure what to change to change the phone column.
One another note, I also need to add a column (C1) to Sheet2 with the title (e.g. CEO, VPs, etc) from the active sheet - is it possible to add that?
Thank you in advance!'

 

[mumps]

This was a bit of a challenge because if the phone number column changes, that also affects the other columns. 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
    phone1 = Rows(1).Find("Phone", LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlNext).Column
    phone2 = Rows(1).Find("Phone", LookIn:=xlValues, lookat:=xlWhole, SearchDirection:=xlPrevious).Column
    workers = Rows(1).Find("Workers", LookIn:=xlValues, lookat:=xlWhole, 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", "Workers")
    v1 = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, phone1).Value
    v2 = Range(Cells(1, workers), Cells(lRow2, workers)).Resize(, phone2).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If Not IsError(Application.Match(v1(i, 1), positions, 0)) And v1(i, 1) <> "" Then
            pos = v1(i, 1)
        End If
        If IsError(Application.Match(v1(i, 1), positions, 0)) And v1(i, 1) <> "" Then
            dic.Add v1(i, 1), v1(i, phone1) & "|" & pos
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If Not IsError(Application.Match(v2(i, 1), positions, 0)) And v1(i, 1) <> "" Then
            pos = v2(i, 1)
        End If
        If IsError(Application.Match(v2(i, 1), positions, 0)) And v2(i, 1) <> "" Then
            dic.Add v2(i, 1), v2(i, phone2 - workers + 1) & "|" & pos
        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

 

[mumps]

I forgot to mention that in order for the macro to work, you must insert the word "Phone" as headers at the top of the two columns containing the phone numbers.

 

[invasivedoc]

I added "Phone" at the top of every column with phone numbers - e.g. cell D1 and J1. However, the macro stops at the phone line in the syntax. Did I understand you wrong?
Thank you for your kind efforts

 

[mumps]

It is working for me. Click here to download your file using some dummy data and run the macro in Module1. The result will be in Sheet2.

 

[invasivedoc]

Hi,
Maybe it is because of too many changes between the dummy and the actual file. I have uploaded a copy here. Thank you so much in advance for your kind help.