Excel VBA PDFファイルテキストをエクセルシートに書き出す

はじめに

PDFファイルテキストをエクセルシートに書き出しを行う

プロシジャーの説明

snipping toolのOCR機能を使います。OCRでテキストデータを読み込んだ後にVBAを起動させ新規シートに転記します。またパラメータシートに明記のテキスト文字を検索させます。

サンプル１

Option Explicit

    Dim x, y, i, j, k As Long
    Dim Sh1x, Sh1y, Sh2x, Sh2y As Long
    Dim EndrowSh1, EndrowSh2, EndrowSh3 As Long
    Dim Haire(100, 3) As Variant
    Dim found As Boolean
    Dim normalizedCellText As String
    Dim normalizedSearchText As String
    Dim ws As Worksheet
    Dim currentTime As String
    
Sub TexttorikomiMain()
    Call FuncParayomi
    Call FuncSheetsakusei
    Call FuncPaste
    Call FuncSeiretu
    
    Sheets(currentTime).Select
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$B$5").AutoFilter Field:=2, Criteria1:="<>"
    
End Sub


Function FuncParayomi()
    Sheets("パラメータ").Select
    EndrowSh2 = Cells(Rows.Count, 1).End(xlUp).Row
    For Sh2x = 1 To EndrowSh2      '段繰返し
        For Sh2y = 1 To 2   '列繰返し
            Haire(Sh2x, Sh2y) = Cells(Sh2x, Sh2y).Value  '配列取込み
        Next Sh2y
    Next Sh2x
End Function

Function FuncSheetsakusei()
    
    ' 現在時刻を取得し、フォーマットを整える（例: 095030）
    currentTime = Format(Time, "hhmmss")
    
    ' 新しいシートを作成
    Set ws = ThisWorkbook.Sheets.Add
    
    ' シート名を現在時刻に変更
    On Error Resume Next ' 名前重複エラーを無視
    ws.Name = currentTime
    If Err.Number <> 0 Then
        MsgBox "シート名が重複しています。処理を中止しました。", vbExclamation
        On Error GoTo 0
        Exit Function
    End If
    On Error GoTo 0
    
    'MsgBox "シート '" & currentTime & "' を作成しました！", vbInformation

End Function


Function FuncPaste()
    'Sheets("チェック").Select
    Sheets(currentTime).Select
    Range("A2").Select
    ActiveSheet.Paste
    Range("A1").Value = "貼付け値"
    Range("B1").Value = "判定"
    
End Function


Function FuncSeiretu()
    'Sheets("チェック").Select
    Sheets(currentTime).Select
    EndrowSh1 = Cells(Rows.Count, 1).End(xlUp).Row
     ' 初期化
    found = False
    
    For i = EndrowSh1 To 2 Step -1
        If (Cells(i, 1) = "") Then
            Rows(i & ":" & i).Select
            Selection.Delete Shift:=xlUp
        Else
            For j = 2 To EndrowSh2
                Call FuncKensaku
            Next j
        End If
    Next i
End Function


Function FuncKensaku()
    ' 全角と半角を統一（半角に変換）し、大文字・小文字の差異をなくす
    normalizedCellText = StrConv(Cells(i, 1).Value, vbNarrow + vbLowerCase)
    'normalizedSearchText = StrConv("x", vbNarrow + vbLowerCase)
    normalizedSearchText = StrConv(Haire(j, 1), vbNarrow + vbLowerCase)
            
    If InStr(1, normalizedCellText, normalizedSearchText, vbTextCompare) > 0 Then
        found = True
        Cells(i, 2).Value = "〇" & Haire(j, 1)
    Else
    End If
End Function

サンプル画像