Extracting part of a string in a column of cells (Site IDs) for each cell in a row and then moving down

[Excel_Ninja]

So I'm trying to extract the Site ID #'s from a table similar to below. Sometimes the table is 10 rows, other times its 50-100. And then there's usually around 10-20 Site IDs in each of the cells I'm looking at which is why this process needs to be automated. I have some code written (see below), however, it's not quite doing what I need. It seems to be skipping over some of the Site IDs and is also not seperating out the Site ID from the Equipment ID. The Site ID should be the first 8 characters (although sometimes I've seen in inputted incorrectly with 9 characters) so an error handler would be ideal. Some other points to keep in mind is not only do I want to export/print out all of the Site IDs I also want to get the Start date, End date, Change ID, etc (which would remain constant per row) as well. I imagine this would work using an offset function. Any help?


[TABLE="width: 500"]
<tbody>[TR]
[TD]Description*[/TD]
[/TR]
[TR]
[TD]Answer the 3 required items below (please provide answers at end of each item): 1. Brief Description of Change (WHAT is being done): Note time is entered in Central Time Zone for a Eastern Time Zone Location The local market has approved day time work due to Safety, Access and Escort Issues Cutover the fALU BBU to the Nokia FSM4 BBU at the following sites: Site ID # Equipment ID # PAL00676 346L00676 PAL00649 346L0649 PAL00653 346L0653 PAL01942 346L1942 DEL05019 346L5019 DEL05023 346L5023 PAL01033 346L1033 PAL01090 346L1090 PAL01099 346L1099 PAL01022 346L1022 PAL04022 181L4022 2. Business Reason (WHY is this change being performed): Nokia FSM4 trial. Validate new Nokia FSM4 BBU for upcoming 2017 deployment nationwide. Note: CR Request exceeds 7 days Per the NPMO Manager[/TD]
[/TR]
[TR]
[TD]Answer the 3 required items below (please provide answers at end of each item): 1. Brief Description of Change (WHAT is being done): Note time is entered in Central Time Zone for a Eastern Time Zone Location The local market has approved day time work due to Safety, Access and Escort Issues Cutover the fALU BBU to the Nokia FSM4 BBU at the following sites: Site ID # Equipment ID # PAL06115 483L6115 PAL04102 181L4102 PAL04048 181L4048 PAL04124 181L4124 PAL04108 181L4108 PAL04026 181L4026 PAL04502 181L4502 PAL04035 181L4035 PAL04011 181L4011 PAL04027 181L4027 PAL04116 181L4116 PAL04127 181L4127 PAL00514 346L0514 PAL00661 346L0661 PAL00537 346L0537 DEL05009 346L5009 DEL05096 346L5096 DEL05021 346L5021 DEL05078 346L5078 DEL05022 346L5022 PAL01030 346L1030 PAL01092 346L1092 PAL01029 346L1029 PAL01031 346L1031 PAL01108 346L1108 PAL04021 181L4021 PAL04017 181L4017 PAL04004 181L4004 PAL04016 181L4016 PAL04114 181L4114 PAL04104 181L4104 PAL04147 181L4147 PAL04112 181L4112 PAL04030 181L4030 PAL04001 181L4001 PAL04043 181L4043 PAL04331 181L4331 2. Business Reason (WHY is this change being performed): Nokia FSM4 trial. Validate new Nokia FSM4 BBU for upcoming 2017 deployment nationwide. Note: CR Request exceeds 7 days Per the NPMO Manager[/TD]
[/TR]
[TR]
[TD]Answer the 3 required items below (please provide answers at end of each item): 1. Brief Description of Change (WHAT is being done): Note time is entered in Central Time Zone for a Eastern Time Zone Location The local market has approved day time work due to Safety, Access and Escort Issues Cutover the fALU BBU to the Nokia FSM4 BBU at the following sites: Site ID # Equipment ID # PAL06078 483L6078 PAL00650 346L0650 2. Business Reason (WHY is this change being performed): Nokia FSM4 trial. Validate new Nokia FSM4 BBU for upcoming 2017 deployment nationwide. Note: CR Request exceeds 7 days Per the NPMO Manager[/TD]
[/TR]
[TR]
[TD]and many more of the same below...[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Code:

Sub exampleUsage2()


Dim idList As Variant
Dim lastRow As Long
idList = extractIDs(ActiveWorkbook.Sheets(1).Range("k2:k3"))

ThisWorkbook.Activate

With ThisWorkbook.Sheets("Destination sheet")
.Range("A1").Value = "Site ID"
.Range("B1").Value = "Original row"
.Range(.Cells(2, 1), .Cells(UBound(idList, 1) + 1, 2)).Value = idList
End With
End Sub






Function extractIDs(rng As Range)


Dim columnArr As Variant
columnArr = rng.Value


Dim startID As String
Dim endID As String
startID = "Equipment ID #" '"Equipment ID #" 'Equipment ID
endID = "Business Reason"


Dim arrSize As Long
Dim i As Long
For i = LBound(columnArr, 1) To UBound(columnArr, 1)
Dim startPos As Long
Dim endPos As Long
startPos = InStr(columnArr(i, 1), startID) + Len(startID) + 1
endPos = InStr(columnArr(i, 1), endID) - 2
columnArr(i, 1) = Mid(columnArr(i, 1), startPos, endPos - startPos + 1)
arrSize = arrSize + ((Len(columnArr(i, 1)) - Len(Replace(columnArr(i, 1), " ", ""))) + 1) / 2
Next


ReDim resultsArr(1 To arrSize, 1 To 2) As String
Dim j As Long
j = 1
For i = LBound(columnArr, 1) To UBound(columnArr, 1)
Dim goAhead As Boolean
goAhead = False
Do Until goAhead = True
Dim firstSpace As Long
Dim nextSpace As Long
firstSpace = InStr(columnArr(i, 1), " ")
If firstSpace = 0 Then
goAhead = True
Else
'Stores ID
resultsArr(j, 1) = Left(columnArr(i, 1), firstSpace - 1)
'Stores original row
resultsArr(j, 2) = i + (rng.Row - 1)
j = j + 1
nextSpace = InStr(firstSpace + 1, columnArr(i, 1), " ")
If nextSpace = 0 Then
goAhead = True
Else
columnArr(i, 1) = Right(columnArr(i, 1), Len(columnArr(i, 1)) - nextSpace)
End If
End If
Loop
Next


extractIDs = resultsArr


End Function