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

2018年3月22日

, , , ,

色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 に変換します。

マクロ

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
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

-コード
-, , , ,

S