【コード】Wordの表をExcelにコピペするWordマクロ

色deチェック上書き翻訳ツールのユーザーさんからツールで作成したWordの対訳表をExcelファイルに貼り付けて管理をしたいと連絡がありました。

普通にコピペをしてもうまく表にならないのです。たとえば、Wordの表のセル内で改行されている場合には、Excelにコピペをしたときにセル内の改行位置で自動的にセルが分割されてしまいます。

その結果、原文(1列目)と訳文(2列目)との対応関係がくずれてしまう場合があります。

(Wordの対訳表)

(Excelに普通にコピペ)

B列の1行目と2行目が結合されてしまいます。

(Excelに「縁浸け先の書式に合わせる」貼り付け)

B列の2行目が空欄になってしまいます。

このマクロでできること

Wordの2列の表をExcelのシート1のA列とB列にコピペします。

文字列のみをコピペします。文字書式(上付き、下付き、文字色など)が解除されますので、ご注意ください。

マクロ実行前

マクロ実行後

列幅は調整しませんが、原文と訳文の対応関係が維持されています。

マクロの解説

Wordファイルの先頭に記載されている2列の表を処理対象にします(23行目)。

Wordファイルの先頭の表が2列ではない場合には実行しませんので、ご注意ください。

WordからExcelを起動する方法はいくつかあるのですが、今回の例ではExcelのインスタンスを複数開いてしまわないように、現在Excelが起動中なのかを判定する処理をつけてみました(29行目~39行目)。

Wordのセル内の文字列をコピペする際に2点処理をします。

1つ目は、Wordのセル内の末尾の改行記号を削除することです(55行目)。

表のセル内の最後の改行記号は、実は通常の改行記号と異なりまして、Chr(13) & Chr(7) の文字コードで表現します。2文字なのです。

なので、この2文字をまず削除します。

2つ目はExcelのセル内改行にあわせて変換します(56行目)。Excelの場合、セル内の改行は [Alt] + [Enter] で挿入しますね。このときに挿入されているのは、vbLf という編集記号です。

Office TANAKA セル内の改行コードに注意

そこで、Wordで使われている改行コード vbCr をExcelの改行コード vbLf に変換します。

マクロ


Sub Wordの表をExcelにコピペする()

 Dim myExcelApp As Object
 Dim myWorkBook As Object
 Dim myWorkSheet As Object
 Dim myDoc As Document
 Dim myTable As Table
 Dim myText As String
 Dim i As Long
 Dim j As Long
  
 '-------------------------------------------
 '前処理
 '-------------------------------------------
 Set myDoc = ActiveDocument
 
 If myDoc.Tables.Count > 0 Then
  Set myTable = myDoc.Tables(1)
 Else
  Exit Sub
 End If
 
 If myTable.Columns.Count <> 2 Then Exit Sub
 
 '-------------------------------------------
 'Excelブックを開く
 '-------------------------------------------
 'Excelが起動中かどうかを判定
 On Error Resume Next
 Set myExcelApp = GetObject(, "Excel.Application")
 
 'Excelが起動していない場合にExcelを起動する
 If Err.Number <> 0 Then
  Err.Clear
  Set myExcelApp = CreateObject("Excel.Application")
  DoEvents
  myExcelApp.Visible = True
 End If
 On Error GoTo 0
 
 'ブックを開く
 Set myWorkBook = myExcelApp.workbooks.Add
 
 'シートを指定
 Set myWorkSheet = myWorkBook.sheets(1)
 
 '-------------------------------------------
 'コピペの開始
 '-------------------------------------------
 For i = 1 To myTable.Rows.Count
 
  '文字列のコピペ
  For j = 1 To 2
   myText = myTable.Cell(i, j).Range.Text
   myText = Left(myText, Len(myText) - 2)
   myText = Replace(myText, vbCr, vbLf)
   myWorkSheet.Cells(i, j).Value = myText
  Next j

  '途中休憩
  If i Mod 20 = 0 Then
   DoEvents
  End If
  
 Next i
 
 '-------------------------------------------
 '後処理
 '-------------------------------------------
 'オブジェクト変数の解放
 Set myDoc = Nothing
 Set myTable = Nothing
 Set myWorkBook = Nothing
 Set myWorkSheet = Nothing
 Set myExcelApp = Nothing

 MsgBox "終了しました。"
 
End Sub

トップへ戻る