Extracting data from a scanned pdf file exported into excel

Question

Here are some screen caps of the data structure of the Excel workbook I am working with:

OK, I have gone through and edited the code based on what everyone has said. It still needs a lot of work though.

What I am stuck on now, is the error handling. Obviously if one of the key words - Last, First, Middle, or Rank - is not found, it will give me an error.

What I am ultimately trying to do is output a blank if there is no value (word) following the key word, and the value word if there is one. If the key word is missing I want to output a blank. It is also possible for the value word to be in the row below the key word. I want to output that value in this case as well.

I am trying to do this now using If-Else statements. However, I think they may be written wrong because if the key word isn't found, I get an error.

Option Explicit

Sub find2()

Dim lrd As Long
Dim lrdWS1 As Long
Dim iRow As Integer
Dim celltosplit As String
Dim result As String

'--------------------------------------------------------------------------------------------------------------------------------------

        lrdWS1 = Sheets("Table 1").Cells(Sheets("Table 1").Rows.count, 1).End(xlUp)(2).Row

        Sheets.Add(After:=Sheets(Sheets.count)).name = "FieldValues"

        lrd = Sheets("FieldValues").Cells(Sheets("FieldValues").Rows.count, 1).End(xlUp)(1).Row

        Worksheets("Table 1").Activate

'--------------------------------------------------------------------------------------------------------------------------------------

Do While Worksheets("Table 1").Activate And Cells.find(What:="Last", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate

Application.Goto (Cells(1, 1))


'--------------------------------------------------------------------------------------------------------------------------------------

    Worksheets("Table 1").Activate
        Application.Goto (Cells(1, 1))

        If Cells.find(What:="Last", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                    False, SearchFormat:=False).Activate Then

                    Selection.Copy
                    Sheets("FieldValues").Activate
                    Range("A" & lrd).Activate
                    ActiveSheet.Paste
                    Columns("A:A").EntireColumn.AUTOFIT


                    Cells.Replace What:="Last", Replacement:="", LookAt:=xlPart, SearchOrder _
                        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

                    lrd = Sheets("FieldValues").Cells(Sheets("FieldValues").Rows.count, 1).End(xlUp)(2).Row

                   Worksheets("Table 1").Activate
                        ActiveCell.UnMerge
                        Selection.Replace What:="Last", Replacement:="", LookAt:=xlPart, SearchOrder _
                                    :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


         Else
                Cells(1, lrd) = ""
                lrd = Sheets("FieldValues").Cells(Sheets("FieldValues").Rows.count, 1).End(xlUp)(2).Row

         End If




'-------------------------------------------------------------------------------------------------------------------------------------

        Worksheets("Table 1").Activate
        Application.Goto (Cells(1, 1))


        If Cells.find(What:="First", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                    False, SearchFormat:=False).Activate Then

                         Selection.Copy
                         Sheets("FieldValues").Activate
                         Range("A" & lrd).Activate
                         ActiveSheet.Paste
                         Columns("A:A").EntireColumn.AUTOFIT


                         Cells.Replace What:="First", Replacement:="", LookAt:=xlPart, SearchOrder _
                           :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


                         lrd = Sheets("FieldValues").Cells(Sheets("FieldValues").Rows.count, 1).End(xlUp)(2).Row


                       Worksheets("Table 1").Activate
                            ActiveCell.UnMerge
                            Selection.Replace What:="First", Replacement:="", LookAt:=xlPart, SearchOrder _
                            :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


        Else
            Cells("1", lrd) = ""
            lrd = Sheets("FieldValues").Cells(Sheets("FieldValues").Rows.count, 1).End(xlUp)(2).Row

        End If


 '-------------------------------------------------------------------------------------------------------------------------------------

        Worksheets("Table 1").Activate
        Application.Goto (Cells(1, 1))

        If Cells.find(What:="Middle", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                    False, SearchFormat:=False).Activate Then

                        Selection.Copy
                        Sheets("FieldValues").Activate
                        Range("A" & lrd).Activate
                        ActiveSheet.Paste
                        Columns("A:A").EntireColumn.AUTOFIT


                        Cells.Replace What:="Middle", Replacement:="", LookAt:=xlPart, SearchOrder _
                         :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


                        lrd = Sheets("FieldValues").Cells(Sheets("FieldValues").Rows.count, 1).End(xlUp)(2).Row


                        Worksheets("Table 1").Activate
                            ActiveCell.UnMerge
                            Selection.Replace What:="Middle", Replacement:="", LookAt:=xlPart, SearchOrder _
                            :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


        Else
            Cells("A", lrd) = ""
            lrd = Sheets("FieldValues").Cells(Sheets("FieldValues").Rows.count, 1).End(xlUp)(2).Row

        End If



'-----------------------------------------------------------------------------------------------------------------------------------------------------------------

        Worksheets("Table 1").Activate
        Application.Goto (Cells(1, 1))


        If Cells.find(What:="Rank", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                    :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                    False, SearchFormat:=False).Activate Then

                        Selection.Copy
                        Sheets("FieldValues").Activate
                        Range("A" & lrd).Activate
                        ActiveSheet.Paste
                        Columns("A:A").EntireColumn.AUTOFIT


                        Cells.Replace What:="Rank", Replacement:="", LookAt:=xlPart, SearchOrder _
                        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

                        lrd = ActiveCell.Row + 2

                        Worksheets("Table 1").Activate

                            ActiveCell.UnMerge
                            Selection.Replace What:="Rank", Replacement:="", LookAt:=xlPart, SearchOrder _
                                    :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

          Else
            Cells("A", lrd) = ""
            lrd = ActiveCell.Row + 2

          End If

Loop

Try using `With` and not `Activate`. Like the example on [Range.Find Method](https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-find-method-excel). Avoid using [Select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) and read these [Best Practices](https://stackoverflow.com/documentation/excel-vba/1107/vba-best-practices#t=201709111852294780854). — danieltakeshi, Sep 11 '17 at 18:50
Also, comment out the `On Error` lines so you can work out what's going on and check whether your search finds anything, and read up on code indentation. Oh, and don't run every operation on every cell in the spreadsheet. — SJR, Sep 11 '17 at 19:01
Your code is too long to look all the way through (surely **something** can be cut out in order to create a MCVE that demonstrates your issue!!) so I'm not going to try to work out your issue, but I did notice a `GoTo EH` on the second page - where `EH` appears to be an error handler. That is dangerous - it will generate an error 20 ("Resume without error"). — YowE3K, Sep 11 '17 at 21:15
@YowE3K Actually, the OP is very lucky. Turns out the `GoTo EH` (and the other 3 equivalent gotos) are inside an `If` block checking to see if any of the cells from a `SpecialCells(xlCellTypeConstants)` filter are equal to "", and only gets executed if any are. Which, of course, never happens. — robinCTS, Sep 12 '17 at 02:35
@robinCTS Actually a blank cell (entered perhaps by simply typing `'` into a cell) will be treated as a constant and is then matched against `""`. (Unlikely that they have done so, but still possible.) — YowE3K, Sep 12 '17 at 02:39
@YowE3K Dammit! You're right. Never realized this. It only works if the cell contain exactly a `'` and nothing else, though. — robinCTS, Sep 12 '17 at 02:43
@robinCTS Yeah, anything else in the cell and it won't be equivalent to a null string, and created any other way it wouldn't be a constant. — YowE3K, Sep 12 '17 at 03:23
Sorry everyone, i'm just now seeing this, I had to leave from my work space and just now have gotten back to where I could access my account. Everyone's comments are very helpful!! I am very new at VBA and have been doing my best to work it by ear, but there is definitely a lot about coding I do not know or understand yet, so thank you all for the feedback!! — Cocoberry2526, Sep 12 '17 at 18:05

robinCTS · Accepted Answer · 2017-09-19T18:12:21.090

I'm sorry, but I have to say it: your code is a complete mess! Everything that everybody said in the comments applies. And more.

Also, you said:

In the code I have a loop set to run and it runs fine the first time

Nope. Not true. Try using more than one word for the First, Middle or Rank field values and see what you get!

The particular problem you posted about arises because after you copy the field values to the FieldValues sheet, instead of only removing the field name from the found field, you're removing that field name from all the cells in the Table 1 sheet! You're using Cells.Replace instead of Selection.Replace.

However, you would be far,far, far better off using the Replace() function instead of the <Range>.Replace method, for example:

Selection.value = replace(Selection.value2,"Last","")

Note that I'm in no way advocating the use of Selection. The correct way would be to have a range object variable, e.g., rngFoundField, and use it like so:

rngFoundField.value = replace(rngFoundField.value2,"Last","")

EDIT: v0.2 - Added basic ID extraction

Based on the supplied screen caps, I've managed to write a procedure that will correctly extract the values of the four fields Last First Middle, and Rank and output them to a new sheet:

'============================================================================================
' Module     : <in any standard module>
' Version    : 0.2
' Part       : 1 of 1
' References : Microsoft Scripting Runtime
' Source     : https://stackoverflow.com/a/46166984/1961728
'============================================================================================
Private Enum i_
    ž__NONE = 0
  ID
  Last
  First
  Middle
  Rank
    ž__
    ž__FIRST = ž__NONE + 1
    ž__LAST = ž__ - 1
End Enum

Public Sub 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"
  Const n_OutputRowsPerRecord As Long = 6

  Dim ƒ As Excel.WorksheetFunction: Set ƒ = Excel.WorksheetFunction
  Dim ¡ As Long

  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
  Dim dictFields As Scripting.Dictionary '##Late Binding: CreateObject("Scripting.Dictionary")
  Set dictFields = New Scripting.Dictionary '##Late Binding: As Object
  With dictFields
    .CompareMode = TextCompare
    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 arngFoundCells(i_.Rank).Row <> arngFoundCells(i_.First).Row Then
            Set arngFoundCells(i_.Rank) = arngFoundCells(i_.First)
          End If
          For Each varFoundCell In arngFoundCells
            strFoundValue = ƒ.Trim(Replace(Replace(varFoundCell.Value2, vbLf, " "), ":", "")) & " "
            If strFoundValue Like "[']*" Then strFoundValue = Mid$(strFoundValue, 2)
            ' ID field: only retain the first word of value
            If LCase$(strFoundValue) Like astrFieldNames(i_.ID) & "*" Then
              strFoundValue = Left$(strFoundValue, InStr(InStr(strFoundValue, " ") + 1, strFoundValue, " "))
            End If
            ' Edge case: no last name value in merged cell -> assume value is in first cell of following row
            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_OutputRowsPerRecord - 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

I expect there to be some edge cases that have been missed. Hopefully these will show up in the immediate window of the VBE.

Let us [continue this discussion in chat](http://chat.stackoverflow.com/rooms/154381/discussion-between-robincts-and-cocoberry2526). — robinCTS, Sep 13 '17 at 18:41

Extracting data from a scanned pdf file exported into excel

1 Answers1