Transpose rows after one specific word

[plshelp95]

Hi everyone!

I've been trying to create a script for this one for several days now but I keep failing.
Here is my data.

Tab 1 is the raw data
Tab 2 is how it should look.

The idea is to transpose values but create a new row once the word 'Skip' shows up.

Any idea how to do this? I really appreciate any help!

 

[OaklandJim]

Is the word "at" in front of all company names? If not then it would be challenging to consistently split title and company.

 

[OaklandJim]

I wrote code that should get you moving. This processes names correctly assuming that they start in cell A2 in Sheet1. Results are put into Sheet2. If Sheet2 does not exist then it is created. If the Title/Company string contains " at " (with spaces) then code will break the string into two pieces and then save them as title and company separately. Otherwise the title will include the entire string.

By the way, I don't think that it is a great idea to post such data on-line. Someone might steal it. I try to use fake data.

Good luck!

Option Explicit
Option Base 1

Sub TransferData()
    
'   Worksheet containing data.
    Dim wsSource As Worksheet
    
'   Worksheet containing results.
    Dim wsTarget As Worksheet
    
'   The last row containing data.
    Dim iLastRow As Long
    
'   Array used to split title/company tring into two pieces.
    Dim SplitArray() As String
    
'   Array used to store results.
    Dim ResultsArray() As String
    
'   Count of rows of results data.
    Dim iRowsToTransfer As Long

'   Range containing the source data.
    Dim rSourceData As Range
    
'   Range containing results data.
    Dim rResultsData As Range
    
'   Cell used for iterating all cells in rSourceData.
    Dim rCell As Range
    
'   Used to keep track of whether the previous row was empty.
    Dim bPreviousWasEmpty As Boolean
    
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    
    On Error Resume Next
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    On Error GoTo 0
    
    If wsTarget Is Nothing _
     Then Set wsTarget = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))

    iLastRow = wsSource.Range("A1").Offset(1000000).End(xlUp).Row
    
    Set rSourceData = wsSource.Cells(1, 1).Resize(iLastRow)
    
    For Each rCell In rSourceData
'
        If UCase(rCell.Value) = UCase("SKIP") Or rCell.Value = "" _
         Then
         
'           Set value = True so for next iteration code knows that the
'           NAME in the "current" row should be processed.
            bPreviousWasEmpty = True
        Else
            
            If bPreviousWasEmpty _
             Then
                
                iRowsToTransfer = iRowsToTransfer + 1
            
                ReDim Preserve ResultsArray(3, iRowsToTransfer)
                
'               Put name into the array
                ResultsArray(1, iRowsToTransfer) = rCell.Value
            
            Else
                
                SplitArray = Split(rCell.Value, " at ", -1, vbTextCompare)
                
'               Put position and company into array
                ResultsArray(2, iRowsToTransfer) = SplitArray(0)
                
'               If split found the string " at " there is a company name.
                If UBound(SplitArray) <> 0 _
                 Then ResultsArray(3, iRowsToTransfer) = SplitArray(1)
            
            End If
            
'           Set value = False so for next iteration code knows that the
'           title/company in the "current" row should be processed.
            bPreviousWasEmpty = False
            
        End If
    
    Next rCell
    
'   Clear any existing data in target worksheet.
    wsTarget.Cells.Clear
    
'   Set the results range (where data goes) based on iRowsToTransfer rows
'   and three columns. Starts in cell A1 as indicated by .Cells(1, 1).
    Set rResultsData = wsTarget.Cells(1, 1).Resize(iRowsToTransfer, 3)

'   Put array into the worksheet.
    rResultsData.Value = Application.Transpose(ResultsArray())
    
    MsgBox "Names processed = " & iRowsToTransfer & ".", vbInformation, "Processing names."
    
End Sub