Excel VBA PDF Converted Text Extraction - vba

Question

I am working with some code that was written for me, and I am having trouble with the Department value. I do not want it to only put out one word which is what it is doing now, and I do not know where to place it so that it doesn't remove all of the text except for just one word. This is the code:
(One of the lines will not space over to change it into a code view and I'm not sure how to fix that)
'===============================================================
Private Enum i_
ž__NONE = 0
ID
Last
First
Middle
Rank
Department
ž__
ž__FIRST = ž__NONE + 1
ž__LAST = ž__ - 1
End Enum
Public Sub EditedVersion_ExtractFieldValues()
Const l_Table_1 As String = "Table 1"
Const l_FieldValues As String = "FieldValues"
Const l_last_first_middle As String = "last first middle"
Const s_FieldNames As String = "id " & l_last_first_middle & " rank" & " department"
Const n_OutputRowsPerRecord As Long = 7
Dim ƒ As Excel.WorksheetFunction: Set ƒ = Excel.WorksheetFunction
Dim ¡ As Long
Dim dictFields As Object
Set dictFields = CreateObject("Scripting.Dictionary")
dictFields.CompareMode = vbTextCompare
With Worksheets
On Error Resume Next
.Add(After:=.Item(.count)).name = l_FieldValues
On Error GoTo 0
Application.DisplayAlerts = False
If .Item(.count).name <> l_FieldValues Then
.Item(.count).Delete
.Item(l_FieldValues).UsedRange.Clear
End If
.Item(l_FieldValues).Columns(1).NumberFormat = "#"
Application.DisplayAlerts = True
.Item(l_Table_1).Activate
End With
Dim astrFieldNames() As String
astrFieldNames = Split(" " & s_FieldNames, " ") ' Force index zero to a blank -> treat as base 1
With dictFields
.CompareMode = vbTextCompare
For ¡ = i_.ž__FIRST To i_.ž__LAST
dictFields.Add astrFieldNames(¡), ""
Next ¡
End With
Dim lngLastUsedRow As Long
lngLastUsedRow _
= Cells _
.find _
( _
What:="*" _
, After:=Cells(1) _
, LookIn:=xlFormulas _
, Lookat:=xlPart _
, SearchOrder:=xlByRows _
, SearchDirection:=xlPrevious _
) _
.Row
With Range(Rows(1), Rows(lngLastUsedRow))
Dim arngFoundCells(i_.ž__FIRST To i_.ž__LAST) As Range
For ¡ = i_.ž__FIRST To i_.ž__LAST
Set arngFoundCells(¡) = .find(What:=astrFieldNames(¡), After:=Cells(1))
Next ¡
Dim lngFirstFoundRow As Long
lngFirstFoundRow _
= ƒ.Min _
( _
arngFoundCells(i_.Last).Row _
, arngFoundCells(i_.First).Row _
, arngFoundCells(i_.Middle).Row _
)
Dim lngOuputSheetNextRow As Long
lngOuputSheetNextRow = 1
Dim varFoundCell As Variant
Dim lngNextFoundRow As Long
Dim rngNextFindStart As Range
Dim astrSplitValues() As String
Dim strFoundValue As String
Dim lngFieldCount As Long
Do
For ¡ = i_.ž__FIRST To i_.ž__LAST
'Debug.Print arngFoundCells(¡).Address; " ";
dictFields.Item(astrFieldNames(¡)) = ""
Next ¡
Debug.Print
Select Case True
Case arngFoundCells(i_.First).Row = arngFoundCells(i_.Middle).Row:
' Edge case: missing rank (found rank is for next employee) -> copy first to rank (simplifies following code)
'If varFoundCels(
If arngFoundCells(i_.Rank).Row <> arngFoundCells(i_.First).Row Then
Set arngFoundCells(i_.Rank) = arngFoundCells(i_.First)
End If
For Each varFoundCell In arngFoundCells
If Not varFoundCell Like astrFieldNames(i_.Department) Then
strFoundValue = ƒ.Trim(Replace(Replace(varFoundCell.Value2, vbLf, " "), ":", "")) & " "
If strFoundValue Like "[']*" Then strFoundValue = Mid$(strFoundValue, 2)
' ID field: only retain the first word of value
End If
If LCase$(strFoundValue) Like astrFieldNames(i_.ID) & "*" Then
strFoundValue = Left$(strFoundValue, InStr(InStr(strFoundValue, " ") + 1, strFoundValue, " "))
End If
' Department field: only retain the first word of value'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''THIS IS THE DEPARTMENT FIELD
If (varFoundCell) Like astrFieldNames(i_.Department) & " " Then
strFoundValue = Trim(varFoundCell.Value)
End If
' Edge case: no last name value in merged cell -> assume value is in first cell of following row
Debug.Print LCase$(strFoundValue)
If LCase$(strFoundValue) Like astrFieldNames(i_.Last) & " " Then
strFoundValue = ƒ.Trim(strFoundValue & Rows(varFoundCell.Row + 1).Cells(1).Value2) & " "
End If
' Edge case: Field names only in row -> assume field values are on the following row
If LCase$(strFoundValue) Like l_last_first_middle & "*" _
And Len(strFoundValue) - Len(Replace(strFoundValue, " ", "")) < 5 _
Then
strFoundValue = ƒ.Trim(strFoundValue & Rows(varFoundCell.Row + 1).Cells(1).Value2) & " "
End If
astrSplitValues = Split(" " & strFoundValue, " ") ' Force index zero to a blank -> treat as base 1
' Array contains one/some/all field names first and then the values (with a possible extra blank value)
lngFieldCount = Int(UBound(astrSplitValues) / 2)
For ¡ = 1 To lngFieldCount
dictFields.Item(astrSplitValues(¡)) = astrSplitValues(¡ + lngFieldCount)
Next ¡
Next varFoundCell
'Only allow the id to be on the previous row
If arngFoundCells(i_.ID).Row <> arngFoundCells(i_.First).Row - 1 Then
dictFields.Item(astrFieldNames(i_.ID)) = 0
End If
Case Else
Debug.Print " SKIPPED: ";
For ¡ = i_.ž__FIRST To i_.ž__LAST
'Debug.Print arngFoundCells(¡).Address; " ";
Next ¡
Debug.Print
For ¡ = i_.ž__FIRST To i_.ž__LAST
Debug.Print " "; ƒ.Trim(arngFoundCells(¡).Value2)
Next ¡
Debug.Print
End Select
Sheets(l_FieldValues).Columns(1).Cells(lngOuputSheetNextRow).Resize(n_OutputRowPerRecord - 1).Value = ƒ.Transpose(dictFields.Items)
lngOuputSheetNextRow = lngOuputSheetNextRow + n_OutputRowsPerRecord
Set rngNextFindStart = Rows(arngFoundCells(i_.First).Row + 2).Cells(1)
For ¡ = i_.ž__FIRST To i_.ž__LAST
Set arngFoundCells(¡) = .find(What:=astrFieldNames(¡),
After:=rngNextFindStart)
Next ¡
lngNextFoundRow _
= ƒ.Min _
( _
arngFoundCells(i_.Last).Row _
, arngFoundCells(i_.First).Row _
, arngFoundCells(i_.Middle).Row _
)
Loop While lngNextFoundRow <> lngFirstFoundRow
End With
End Sub