色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 という編集記号です。
そこで、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
