Wordから転記した表で小ハマリ…… - 素人がExcelVBAによる「一人働き方改革」に挑むブログ

前にコチラで紹介した、

Wordの表からExcelの表にデータを転記するマクロ

なんですが、またしても軽くハマったので、覚書も兼ねて上げておく。

第１段階

f:id:akashi_keirin:20170313230205j:plain

Wordのこんな表から、

f:id:akashi_keirin:20170313230211j:plain

Excelのこんな表にデータをマクロで転記した。

使用したコード

Option Explicit
Sub transferFromWordTable()
On Error GoTo myError
  Err.Clear
  Dim tgtRow As Integer
  tgtRow = ThisWorkbook.Worksheets("Main").Cells(Rows.Count, 2).End(xlUp).Row + 1
  Dim n As Integer
  n = tgtRow  '書き込み開始行を保持しておく
  '参照設定でWordのオブジェクトライブラリにチェックを入れている。
  Dim objWord As Word.Application
  Dim objDoc As Document
  Dim objFileName As String
  Dim objFolderName As String
  Set objWord = GetObject(, "Word.Application")
  Set objDoc = objWord.ActiveDocument
  objFileName = objDoc.Name
  objFolderName = ThisWorkbook.Path & "\★hogehoge\"
  With ThisWorkbook.Worksheets("Main")
    .Range("A" & tgtRow).Value = objWord.Selection.Text
    Dim i As Integer
    For i = 2 To 9
      .Range("B" & tgtRow + i - 2).Value = Left(objDoc.Tables(1).Cell(i, 1).Range.Text, _
                                                Len(objDoc.Tables(1).Cell(i, 1).Range.Text) - 1)
      .Range("C" & tgtRow + i - 2).Value = Left(objDoc.Tables(1).Cell(i, 2).Range.Text, _
                                                Len(objDoc.Tables(1).Cell(i, 2).Range.Text) - 1)
      .Range("D" & tgtRow + i - 2).Value = Left(objDoc.Tables(1).Cell(i, 3).Range.Text, _
                                                Len(objDoc.Tables(1).Cell(i, 3).Range.Text) - 1)
      .Range("E" & tgtRow + i - 2).Value = Left(objDoc.Tables(1).Cell(i, 4).Range.Text, _
                                                Len(objDoc.Tables(1).Cell(i, 4).Range.Text) - 1)
    Next
    tgtRow = ThisWorkbook.Worksheets("Main").Cells(Rows.Count, 2).End(xlUp).Row
    For i = n To tgtRow
      If .Range("B" & i).Value = vbCr Then
        .Range("B" & i).Value = ""
      End If
    Next
  End With
  objDoc.Close False
  If objWord.Documents.Count = 0 Then
    objWord.Quit
  End If
  Set objWord = Nothing
  Set objDoc = Nothing
  Name objFolderName & objFileName As _
       objFolderName & "転記済み\" & objFileName
  Exit Sub
myError:
  Debug.Print Err.Number & ":" & Err.Description
  Word.Application.Quit
End Sub

実行結果

f:id:akashi_keirin:20170313230218j:plain

こんな風に転記された。

第２段階

転記してできた表に対して、次のような処理を行うことにした。

「吉岡タイトル」列（Ｆ列）を選択してマクロ実行
Ｃ列～Ｅ列を順に調べ、一つでも「吉岡　稔真」と書かれたセルがあったらＦ列に「○」をつける。

まあ、実にしょうもないマクロだが、こんなことをしたと思ってほしい。

使用したコード

Sub checkTitleOfYoshioka()
  Dim objCell As Range
  Set objCell = ActiveCell
  Dim i As Integer
  With ThisWorkbook.Worksheets("Main")
    For i = 3 To 5
      If .Cells(objCell.Row, i).Value = "吉岡　稔真" Then
        .Cells(objCell.Row, 6).Value = "○"
        Exit For
      End If
    Next
  End With
End Sub

プロシージャ名が「checkTitleOfYoshioka」とか、アホ丸出しだが、許せしてください。