ワードからエクセル台帳に転記

Option Explicit

Public OKdate As String, wd As Word.Application, doc As Word.Document


Sub ワードから台帳転記()
Dim parts As String, ファイル保管場所 As String

'記載元のワードが保存されたパスを入力。このマクロではデスクトップの想定です。
ファイル保管場所 = Environ("USERPROFILE") & "\Desktop"
Call 申請登録
If OKdate = "" Then Exit Sub

If MsgBox("フォルダ作成保管", vbYesNo + vbSystemModal) = vbYes Then

'フォルダの作成と保管
    If Dir(ファイル保管場所 & "\" & OKdate, vbDirectory) <> "" Then
        MsgBox "フォルダ作成できませんでした。すでにフォルダがある可能性があります。"
        
        Else
            MkDir (ファイル保管場所 & "\" & OKdate)
            '引数にパスワード設定すれば,保護もできます。
            'doc.Protect wdAllowOnlyReading
            doc.SaveAs2 ファイル保管場所 & "\" & OKdate & "\" & doc.Name
End If
End If


End Sub



Sub 申請登録()

    Dim yymm As String, mm As String, 連番 As String, pnt As Range
    Dim plant As String, r As Long, i As Long, cel13 As String
    Dim wdname As String
    Set wd = New Word.Application 'ここでエラー
    Dim prg As Long, rng0 As Variant

    Worksheets(1).Activate

    ' 台帳から承認Noを取得設定
    Set pnt = Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
    yymm = Format(CStr(Date), "yymm")

    ' 新しい月の場合
    If yymm <> Mid(pnt.Offset(-1).Value, 4, 4) Then
        OKdate = "ABC" & yymm & "01"
        pnt = OKdate
    ' その月の場合
    Else
        連番 = Format(Val(Mid(pnt.Offset(-1).Value, 8)) + 1, "00")
        OKdate = "ABC" & yymm & 連番
        pnt = OKdate
    End If

    ' ワードを開き、承認No記入と台帳へのコピペ
    wdname = Application.GetOpenFilename
    If wdname = "False" Or wdname = "" Then Exit Sub

    On Error Resume Next
    Set doc = wd.Documents.Open(wdname, , True)
    If doc Is Nothing Then Exit Sub
    wd.Visible = True
    doc.Paragraphs(4).Range.Select
    wd.Selection.InsertAfter OKdate
    On Error GoTo 0

    ' 台帳へ転記
    ' 発行番号
    pnt.Offset(, 2) = doc.Paragraphs(kensaku("*発*行*番*号") + 1).Range

    ' 発行日
    pnt.Offset(, 1) = doc.Paragraphs(7).Range
    If InStr(1, pnt, " ", vbTextCompare) <> 0 Then
        pnt.Offset(, 1) = Replace(pnt, " ", "", , , vbTextCompare)
    End If

    ' 会社
    On Error Resume Next
    plant = doc.Paragraphs(kensaku("所*属*") + 1).Range
    pnt.Offset(, 3) = plant

    ' 所属部門、課
    pnt.Offset(, 5) = Left(doc.Paragraphs(kensaku("*部門*") + 1).Range, _
                           VBA.InStr(doc.Paragraphs(kensaku("*部門*") + 1).Range, "/", , vbTextCompare) - 1)
    pnt.Offset(, 6) = Mid(doc.Paragraphs(kensaku("*部門*") + 1).Range, _
                          VBA.InStr(doc.Paragraphs(kensaku("*部門*") + 1).Range, "/", , vbTextCompare) + 1)

    ' 氏名
    pnt.Offset(, 4) = doc.Paragraphs(kensaku("氏*名") + 1).Range

    ' 理由
    pnt.Offset(, 7) = doc.Range(doc.Paragraphs(kensaku("理*由") + 1).Range.Start, _
                                doc.Paragraphs(kensaku("採*用*") - 1).Range.End)

    ' 文章内の改行削除
    r = pnt.Row
    For i = 2 To 28
        Cells(r, i) = WorksheetFunction.Clean(Replace(Cells(r, i), " ", "", , , vbTextCompare))
    Next

    ' Wordの許可に丸を付ける
    Dim shape As Object
    Set shape = doc.Shapes.AddShape(Type:=msoShapeOval, _
                                    Left:=440, _
                                    Top:=105, _
                                    Width:=20, _
                                    Height:=20)
    shape.Fill.Visible = msoFalse ' 塗りつぶしなし
    shape.WrapFormat.Type = wdWrapBehind ' テキストとの折り返しを「背面」に設定

    On Error GoTo 0

End Sub



Function kensaku(検索値 As String)
    Dim prg0 As Variant, prg As Long
    Dim rng As Object
    Dim firstSectionRange As Object
     Dim startPos As Long
    
    ' 最初のセクションの範囲を取得
    Set firstSectionRange = doc.Sections(1).Range
    
     ' 最初の段落を除外するために開始位置を調整
    startPos = firstSectionRange.Paragraphs(1).Range.End
    Set rng = doc.Range(startPos, firstSectionRange.End)
   
    
    ' 最初のセクション内で検索を実行
    'Set rng = firstSectionRange.Duplicate ' 元の範囲を複製するやり方もあります。（参考）
    With rng.Find
    ' ドキュメント指定範囲から検索
        .Text = 検索値
        .MatchFuzzy = False
        .MatchWildcards = True
        If .Execute Then
            ' 検索結果が見つかった場合の処理
            Set prg0 = doc.Range(.Parent.Start, .Parent.End)
            prg0.Start = 0 ' 開始位置をドキュメントの先頭にリセット
            prg = prg0.Paragraphs.Count
        Else
            ' 検索結果が見つからなかった場合
            prg = -1 ' 見つからなかった場合の返却値（任意で変更可能）
        End If
    End With
    
    ' 結果を返す
    kensaku = prg
End Function