ワードからエクセルへ貼り付けるマクロ

ワードの内容をそのままエクセルに貼り付けたいのですが、
ファイル数が多いためマクロを活用して自動化したいと思っています。

フォルダ内にあるワードを全て処理するにはどうしたら良いでしょうか。

手順としては下記の繰り返しです。
1.Word書類を開く
2.すべて選択しコピー(Ctrl+A、Ctrl+Cと同意)
3.エクセルにそのまま貼り付ける

ワードのファイル名が、そのままエクセルのファイル名 or シート名になると助かります。


自分用のツールなので、親切なインターフェースは不要です。
例えば、VBAソースを編集して、フォルダパスを登録等でOK。

ワードとエクセルのどちらのマクロを使うべきか分からないので、
ご存知の方ご教示願えないでしょうか？

No.10 回答者： WindFaller 回答日時： 2018/04/29 11:01

>ちなみにSheet2が必要なのにはどんな理由があるのですか？

>(Sheet2を削除してからマクロ実行したらエラーが出ました。)

直接的には、私のワークブックの使い方です。最初のシートに一覧を作ることが多いからで、それをシート1をメインシートにして、後は、全部、埋め尽くすのです。シート1だけでもよいのですが、あまりにも貧相なので、シート2を残すようにして、それをスタートにしています。シート3からでも、シート4からでも、アクティブシートを最初のページにすることは可能ですが、今は、

ThisWorkbook.Worksheets(2).Activate

これがあるので、インデックスエラーにはなるのですが、これを取り去れば、2以降が可能になります。

シート1枚のみからの実行は事実上できなようですから、もしシート1枚だけらなら、新たに挿入するコマンドを入れなくてはなりません。これも、どちらかというと、アドイン型か、外部ツール型のコードです。

No.9 回答者： WindFaller 回答日時： 2018/04/28 05:18

改めて、こちらで試してみました。

#8のコードを新規のブック(Excel 2010)の、
・「標準モジュール」に貼り付け

・参照設定では、Microsofot Word 14.0　Object Library を設定し

・コードの中の
　Private Const MyPATH As String = "E:\**\" '末尾に￥を入れること
　を自分の環境にあった場所に直し、リミッターは、100以上になっているので、そのままにしました。

・シート1に、フォームコントロールボタンを設けて、マクロ登録は「Import_wordDoc2」
にしました。

・もうひとつフォームコントロールで、マクロ登録「DelSheet2」を付けて置きました。

こうして、一旦、「WordTrans.xlsm」 というブックに名前を付けて、保存して、再度、オープン。セキュリティの警告もなく開けました。シート1のインポート・ボタンをクリックしてみました。Wordの文書がインポート出来ています。

どこかに手順などの違いはあるのではないでしょうか。

このブックを、別のパソコンに移せば、警告が出ますが、黄色い帯（イエローバンド)のクリックして消せば、使えるようになるはずです。なお、いろいろ検証してみましたが、VBAマクロにおいて、警告表示の取れないものは見当たりませんでした。

VBA以外では、内部の構成を変えないと警告がとれないものがありますが、これは、今回の要件とはまったく関わり合いのない内容です。しかし、新規のブックで試してみるのが安全かと思います。

この回答へのお礼

手順を詳細に教えていただいてありがとうございます。
その通りにやり直したらできました！
マクロの扱いに慣れてないので、手順が違ってたんだと思います。

これは、Ctrl＋Aで手動でコピペしたのと同じ結果に見えます。すごいですね！

ちなみにSheet2が必要なのにはどんな理由があるのですか？
(Sheet2を削除してからマクロ実行したらエラーが出ました。)

お礼日時：2018/04/28 18:44

No.8 回答者： WindFaller 回答日時： 2018/04/26 21:37

「サブルーチン・マクロが完全に抜けてしまう現象が見れます。

だめだった時は、もう一度、最初から試しててみてください」おまけの「シート削除用マクロ」は、一番下に置きます。

'Option Explicit

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
'Sleepは、使われていない。
Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const VK_CONTROL = &H11
Private Const VK_V = &H56
Private Const VK_C = &H43
Private Const VK_A = &H41
Private Const KEYEVENTF_KEYUP = &H2

Private Const MyPATH As String = "E:\WordDoc\" '末尾に￥を入れること

Dim objWord As Word.Application '要・参照設定
Sub Import_wordDoc2()
Dim FName
Dim cnt As Long, i As Long
Dim shCount As Long
Dim mySh As Worksheet
ThisWorkbook.Worksheets(2).Activate

Set objWord = New Word.Application

objWord.Visible = True
i = ActiveSheet.Index 'スタートの位置　(私の場合は、Sheet2を開けて実行します)
shCount = ThisWorkbook.Worksheets.Count - cnt '残りのシート数
cnt = i

FName = Dir(MyPATH & "*.doc?", vbNormal)
Do While FName <> ""
If FName <> "." And FName <> ".." Then
If (GetAttr(MyPATH & FName) And vbNormal) = vbNormal Then
With ThisWorkbook
If cnt > shCount Then
Set mySh = .Worksheets.Add(After:=.Worksheets(shCount))
Else
Set mySh = .Worksheets(cnt)
End If
Call OpenWordDoc2(MyPATH & FName, mySh)
shCount = ThisWorkbook.Worksheets.Count
cnt = cnt + 1
If cnt >100 Then Exit Sub 'リミッター
End With
End If
End If
FName = Dir
Loop
objWord.Quit
Set objWord = Nothing
End Sub
Private Sub OpenWordDoc2(ByVal FName As String, Dest As Worksheet)
Dim wdDoc As Word.Document
Dim wdRng As Object
Dim shName As String
Dim hWnd As Long
Dim hWnd_c As Long
Dim hWnd_c2 As Long
Dim wdhWnd As Long
Dim wdhwndw_C As Long
Dim fmtFlg As Boolean
Dim f As Variant
On Error GoTo ErrHandler
DoEvents
Set wdDoc = objWord.Documents.Open(FName, , True)
wdDoc.Application.ActiveDocument.Repaginate
AppActivate wdDoc.Application.Caption
On Error Resume Next
With wdDoc.Application.Selection
.WholeStory
.Copy
DoEvents
End With

On Error GoTo 0
AppActivate ActiveWindow.Caption
ThisWorkbook.Windows(1).Activate
'Ctrl + v
keybd_event VK_CONTROL, 0, 0, 0
keybd_event VK_V, 0, 0, 0
keybd_event VK_V, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_CONTROL, 0, KEYEVENTF_KEYUP, 0
Beep
ActiveSheet.UsedRange.Columns.AutoFit
Dest.Name = wdDoc.Name
shName = ""
Application.ScreenUpdating = True
ErrHandler:
wdDoc.Close False
Set wdDoc = Nothing
End Sub

'-----------------
Sub DelSheet2()
'シート1にボタンをおいて実行
Dim cnt As Long
Dim i As Long
With ThisWorkbook
cnt = .Worksheets.Count
If cnt < 2 Then
.Worksheets.Add After:=.Worksheets(1)
Exit Sub
End If
.Worksheets(2).Select
For i = 2 To cnt
.Worksheets(i).Select False
Next i
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
.Worksheets.Add After:=.Worksheets(1)
End With
End Sub

No.7 回答者： WindFaller 回答日時： 2018/04/26 21:28

>マクロ 'サンプル.xlsm!Import_wordDoc'を実行できません。

このブックでマクロが使用できないか、またはすべてのマクロが無効になっている可能性があります。

別のパソコンの、Excel 2013で、おっしゃっている警告を出してみました。
このセキュリティに関しては、なんとかご自身で解決してください。

開発タブを開くと、デザインモードになっているはずです。
マクロのセキュリティを開けますと、
「警告を表示せずにすべてのマクロを無効にする(L_)」に、黒丸が入っているはずです。

前回のような設定で、エクセルを再起動すると、下記の添付のイエローバンドの警告が出ますから、
「!セキュリティの警告　一部のアクティブ　コンテンツが無効にされました。クリックすると詳細が表示されます。『コンテンツの有効化』」
その「コンテンツの有効化」を、クリックして解除します。

場合によっては、新しく、ブックを作り直すと簡単に解除できるはずです。

なお、今回のマクロは、Excel2010で作られたものですから、上位バージョンのために作り直したものを、この後に出します。

また、別のPCで試してみた結果、Wordのファイル群とエクセルの実行ファイルとの論理的距離が遠いと(C:\->D:\ /:\OneDrive\->C:\)ですと、マクロがまったく動かないこともあります。

下位バージョンでの警告文は、
》セキュリティの設定により、マクロが無効にされました。マクロを実行するには、このブックを再度開いて、マクロを有効にするよう選択する必要があります。マクロの有効化の詳細については、[ヘルプ]をクリックしてください。

この回答へのお礼

ご親切にありがとうございます！
できるだけ負担がかからない様に、事前にお伝えしていなかった情報を明記します。
・当方、Office2010しか使用してませんので他のバージョンの考慮は不要です。(Excel2007もExcel2013も所有していません)

また、
・終日、常にマクロを使用した作業をしているので、セキュリティ警告についての可能性は除外してください。
・・・と言いたいところですが、明日、改めて初心に帰って上記を再度一からチェックしなおします。
よろしくお願いいたします。

お礼日時：2018/04/27 01:54

No.6 回答者： WindFaller 回答日時： 2018/04/25 18:19

>「マクロを実行できません。

このブックでマクロが使用できないか、またはすべてのマクロが無効になっている可能性があります。」

これはエラーメッセージではなく、セキュリティの警告です。
通常使わないフォルダーからExcelマクロを起動していたりするのではありませんか？
------------------
オプションのセキュリティセンター－>
　「マクロの設定」－警告を表示してすべてのマクロを無効にする(D)
　「信頼できる場所」起動するフォルダーを加える (任意－利用度が増えた場合など)

この設定したら、一旦、Excelを閉じて、再びExcelを起動して、マクロのファイルを選択して開けます。セキュリティの警告というのが、リボンメニューの一番下に出てきますから、それで、マクロを有効化します。
--------------------
そのメッセージ自体は、こちらのマクロのエラーではありません。

この回答へのお礼

ありがとうございます。
今回作成したファイル名は、サンプル.xlsm です。
再度実行して表示されたエラーメッセージを正確に転記します。
------------------
マクロ 'サンプル.xlsm!Import_wordDoc'を実行できません。このブックでマクロが使用できないか、またはすべてのマクロが無効になっている可能性があります。
------------------
↑の通りです。

Excelマクロのセキュリティ設定は見直しましたので問題ないはずです。
※当然その他のマクロはバンバン使ってます。

何か手がかりになると幸いです。

お礼日時：2018/04/26 15:34

No.5 回答者： WindFaller 回答日時： 2018/04/23 20:03

こんばんは。

この方法は使いたくなかったけれども、やむを得ないと思いました。
最初の試用で、使用後のキーの設定は、問題ないか注意してください。
こちらでは問題はなかったのですが、この種の方法は、あまり賛成しないやり方です。
「マクロの記録で、エクセル、マクロ間の動作を記録できますか? 」
こちらの方の質問は、成功したのですか？そんなに簡単だとは思えないのですが。
いくつかコメントが書いてありますが、特に、
　' ' Application.ScreenUpdating = True '理由は分からないが画面は活性化しない
は、このメソッドを入れても、マクロが終わるまで、画面が変わらないのです。

'//
'Option Explicit

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const VK_CONTROL = &H11
Private Const VK_V = &H56
Private Const KEYEVENTF_KEYUP = &H2

Const MyPATH As String = "C:\Users\Wendy\Documents\WordDoc\"

Dim objWord As Word.Application '要・参照設定(重要)
Sub Import_wordDoc2()
　Dim FName
　Dim cnt As Long, i As Long
　Dim shCount As Long
　Dim mySh As Worksheet
' ' ThisWorkbook.Worksheets(2).Activate '私個人は、2シート目から

　Set objWord = New Word.Application

　objWord.Visible = True
　i = ActiveSheet.Index 'スタートのいち
　shCount = ThisWorkbook.Worksheets.Count - cnt '残りのシート数
　cnt = i

　FName = Dir(MyPATH & "*.doc?", vbNormal)
　Do While FName <> ""
　　If FName <> "." And FName <> ".." Then
　　　If (GetAttr(MyPATH & FName) And vbNormal) = vbNormal Then
　　　　With ThisWorkbook
　　　　　If cnt > shCount Then
　　　　　 Set mySh = .Worksheets.Add(After:=.Worksheets(shCount))
　　　　　Else
　　　　　 Set mySh = .Worksheets(cnt)
　　　　　End If
　　　　　Call OpenWordDoc2(MyPATH & FName, mySh)
　　　　　shCount = ThisWorkbook.Worksheets.Count
　　　　　cnt = cnt + 1
　　　　　If cnt > 20 Then Exit Sub
　　　　End With
　　　End If
　　End If
　　FName = Dir
　Loop
　objWord.Quit
　Set objWord = Nothing
End Sub
Private Sub OpenWordDoc2(ByVal FName As String, Dest As Worksheet)
　Dim wdDoc As Word.Document
　Dim wdRng As Object
　Dim shName As String
　Dim Hwnd As Long
　Dim hWnd_c As Long
　Dim hWnd_c2 As Long
　Dim wdhWnd As Long
　Dim wdhwndw_C As Long
　Dim fmtFlg As Boolean
　Dim f As Variant
　On Error GoTo ErrHandler
　DoEvents
　Set wdDoc = objWord.Documents.Open(FName, , True)
　wdDoc.Application.ActiveDocument.Repaginate

　With wdDoc.Application.Selection
　　.Goto What:=wdGoToPage, Which:=wdGoToFirst
　 .EndKey Unit:=wdStory, Extend:=wdExtend
　 .Copy
　End With
　AppActivate ActiveWindow.Caption
　ThisWorkbook.Windows(1).Activate
'Ctrl + v
keybd_event VK_CONTROL, 0, 0, 0
keybd_event VK_V, 0, 0, 0
keybd_event VK_V, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_CONTROL, 0, KEYEVENTF_KEYUP, 0
　Beep 'あってもなくても良い
　Sleep 2000 'あってもなくても良い
　' 'ActiveSheet.UsedRange.Columns.AutoFit '効いていない
　Dest.Name = wdDoc.Name
　shName = ""
　' ' Application.ScreenUpdating = True '理由は分からないが画面は活性化しない
ErrHandler:
　wdDoc.Close False
　Set wdDoc = Nothing
End Sub

この回答へのお礼

ありがとうございます。
下記のエラーメッセージが出て動作確認できませんでした^^;
↓
「マクロを実行できません。このブックでマクロが使用できないか、またはすべてのマクロが無効になっている可能性があります。」
もちろんマクロ無効にはしてないです。前回のソースに貼り換えたらきちんと動作しました。


>「マクロの記録で、エクセル、マクロ間の動作を記録できますか? 」

成功してませんよ。

完全解決できなさそうなので、手作業で処理する事も視野に入れております。
アドバイスあれば助かります。

お礼日時：2018/04/25 12:14

No.4 回答者： WindFaller 回答日時： 2018/04/20 17:05

>表組ではなくなったので、今回の案件に使えそうなのか検証してみます。

(ちょっと時間がかかるかも)

Wordの表組みって、取り出し方が違ったと思います。
その部分だけの名称が用意されていたはずです。
私は、このところ、タブレットでは、ここを読んでいたりしますが、ずっと体調が思わしくなくて、パソコンに向かう時間が減っています。もう一度、トライしてみます。

この回答へのお礼

体調悪いのに考えていただいてありがとうございます。
無理しないでくださいね。

お礼日時：2018/04/25 12:14

No.3 回答者： WindFaller 回答日時： 2018/04/19 14:18

通常、OCR などのWordへの転記は、私がマクロで示したようになっています。

Wordのオブジェクトは、エクセルよりも複雑だから、Excelで使うデータとは違うものが含まれているようです。

>Word上でCtrl+C、Excel上でCtrl+V動作を自動化するのは無理でしょうか？
この場合は、Win32 APIを利用するのですが、マクロで行うと、マクロが早すぎて、貼り付けが抜けてしまいます。オブジェクトのサイズが複雑で大きいからではないでしょうか。

CTrl + C
wdhWnd = FindWindow("OpusApp", vbNullString)
wdhwndw_C = FindWindowEx(wdhWnd, 0&, vbNullString, vbNullString)
Call SendMessage(wdhwndw_C, WM_COPY, 0&, ByVal 0)

こんな感じで、ClipBoard に格納はされています。
しかし、Excel側は、
Ctrl + V は、なかなか出てきません。
Wnd_C = FindWindowEx(Application.Hwnd, 0&, vbNullString, vbNullString)
Call SendMessage(hWnd_C, WM_PASTE, 0&, ByVal 0)
もしかしたら、これが違うというか、物理的な Ctrl+ V を送る方法もあります。
一応、試してみるつもりですが、物理的なCtrl +V は、2重の動作で、押して＋戻して　がCtrl キーと、Vキーとが相互作用するので、とても面倒なのです。

SendKeys自体は、対象物が定まらないので、私は、あまり関心しません。
このコードに書き入れること自体は、ご自由ですが、私はしないというだけです。

もし、ご自身でされるなら、UWSC で試してみたらいかがでしょうか？
私のこのコードよりもずっと易しく、確実に　WinAPI を書くことができます。

今の代用としては、Value の貼り付けを考えてみました。

'//
Const MyPATH As String = "C:\Users\Documents\WordDoc\"

Dim objWord As Word.Application '要・参照設定
Sub Import_wordDoc()
　Dim FName
　Dim cnt As Long, i As Long
　Dim shCount As Long
　Dim mySh As Worksheet

　Set objWord = New Word.Application

　objWord.Visible = True
　i = ActiveSheet.Index 'スタートのシートの位置
　shCount = ThisWorkbook.Worksheets.Count - cnt '残りのシート数
　cnt = i

　FName = Dir(MyPATH & "*.doc?", vbNormal)
　Do While FName <> ""
　　If FName <> "." And FName <> ".." Then
　　　If (GetAttr(MyPATH & FName) And vbNormal) = vbNormal Then
　　　　With ThisWorkbook
　　　　　If cnt > shCount Then
　　　　　 Set mySh = .Worksheets.Add(After:=.Worksheets(shCount))
　　　　　Else
　　　　　 Set mySh = .Worksheets(cnt)
　　　　　End If
　　　　　Call OpenWordDoc(MyPATH & FName, mySh)
　　　　　shCount = ThisWorkbook.Worksheets.Count
　　　　　cnt = cnt + 1
　　　　　''If cnt > 10 Then Exit Do 'リミッター
　　　　End With
　　　End If
　　End If
　　FName = Dir
　Loop
　objWord.Quit
　Set objWord = Nothing
End Sub
Sub OpenWordDoc(ByVal FName As String, Dest As Worksheet)
　Dim wdDoc As Word.Document
　Dim wdRng As Object
　Dim shName As String
　On Error GoTo ErrHandler
　DoEvents
　Set wdDoc = objWord.Documents.Open(FName, , True)
　wdDoc.Application.ActiveDocument.Repaginate

　With wdDoc.Application.Selection
　　.Goto What:=wdGoToPage, Which:=wdGoToFirst
　 .EndKey Unit:=wdStory, Extend:=wdExtend
　 .Copy
　End With
　ThisWorkbook.Windows(1).Activate
　Dest.Activate
　Dest.Range("A1").Select
　Dest.Range("A1").PasteSpecial xlPasteValues 'Value の貼り付け
　Application.Wait Now() + TimeSerial(0, 0, 1)
　Dest.Name = wdDoc.Name
　shName = ""
ErrHandler:
　wdDoc.Close False
　Set wdDoc = Nothing
End Sub

この回答へのお礼

ありがとうございます。
今度はオブジェクトとしてではなく、値で貼り付けられました。なるほど、「xlPasteValues 」ですね。
表組ではなくなったので、今回の案件に使えそうなのか検証してみます。(ちょっと時間がかかるかも)

UWSC も他の案件で活用できそうです。というか、こういうのも探してました。
非常に助かります。

お礼日時：2018/04/19 16:46

No.2 回答者： WindFaller 回答日時： 2018/04/13 23:34

>これはWordとExcelのどちらのマクロでしょう？

Excelです。
わかにくい内容だったかもしれません。

>Dim objWord As Word.Application '要・参照設定
Wordは、事前バインディングしていないと、マクロが追いつかないです。

今回のマクロはリミッターがついていませんから、無茶な使い方をすれば、パンク(ハング状態）になります。せいぜい、32bit環境で200枚が限度だと思います。マクロを動かす分には分かりませんが、作る側からは、Wordは物理的なのです。本来は、Text化したほうがよいのですが、そのままにしました。また、Word VBAは、Excelほど、本体と分離して扱うことができません。

話が前後しますが、Ctrl + C -> Ctrl + V でよく、プライベートで行うなら、UWCS(キーボードマクロ）をお使いになる方法もあります。このツール(フリー）は、VBAの最高難度のマクロコードを複数のアプリ間で簡単に行え、Basicライクのプログラミング言語を持ち、Excel自体をオブジェクト(有償版）として扱えるものです。

https://www.vector.co.jp/soft/winnt/util/se11510 …

この回答へのお礼

アドバイス、ありがとうございます。
リミッターなどついてないから、大量処理には気を付ける点、承知しました。数十ファイル程度なので大丈夫です。

先日のソースにてテストしました。
確かに動作しましたが、結果が想定外でした^^;

記載のソースでテストしたところ、
確かに
・シート名がWordファイル名
・該当ワードの内容が貼り付け
という結果で間違ってはいません。

しかし、エクセルのシートにワードのページ全体が埋め込みオブジェクトとして貼られる結果となりました。
(ダブルクリックするとワードの編集画面になります。)

なるほど、こういう貼り方もある事を想定してませんでした。


私が自動化したかったのは以下のような動きでした。

(1)ワードファイルを開き、Ctrl+A。
　　⇒「全て選択」状態になります。
(2)そのままCtrl+C。
　　⇒クリップボードにコピーされます。
(3)エクセルSheet1のA1にてCtrl+V。
　　⇒クリップボードの内容が貼り付けられます。

手動で上記操作をすると、
行ごとに分かれて、各セルに貼られるのが確認できます。
すると表などがエクセル上に再現されるのです。
そのあとエクセル上で、全シートから、目的の項目を結合して一覧化する等の作業をしたかったのです。
単純にWord上でCtrl+C、Excel上でCtrl+V動作を自動化するのは無理でしょうか？

お礼日時：2018/04/16 17:01

No.1 回答者： WindFaller 回答日時： 2018/04/12 23:08

こんばんは。

>ワードとエクセルのどちらのマクロを使うべきか分からないので、
>ご存知の方ご教示願えないでしょうか？

前回、そのままになってしまいスミマセンでした。
本当は、別の訳ありなのですが、言い訳はしません。
修正を繰り返してみたのですが、自分の中で満足できるものではありませんでした。

さて、今回、WordとExcelのマクロなら、Excelのほうが逃げ場が多いので、Excel側に作るべきなのですが、私は、Wordマクロをすっかり忘れていました。今回のご質問で、少し思い出しました。
ExcelのEndプロパティが、Wordにはないのでした。それに開いた時点では、全部メモリに入っていないようなのです。Excelからすると、すごく物理的という感じです。

必ず、参照設定で、Microsoft Word にチェックを入れてください。CreateObject では追いつかないようです。

'//
Option Explicit
Const MyPATH As String = "C:\Users\Documents\WordDoc\"　'パス

Dim objWord As Word.Application '要・参照設定
Sub Import_wordDoc()
　Dim FName
　Dim cnt As Long, i As Long
　Dim shCount As Long
　Dim mySh As Worksheet

　Set objWord = New Word.Application
　objWord.Visible = True
　i = ActiveSheet.Index 'スタートのいち
　shCount = ThisWorkbook.Worksheets.Count - cnt '残りのシート数
　cnt = i

　FName = Dir(MyPATH & "*.doc?", vbNormal)
　Do While FName <> ""
　　If FName <> "." And FName <> ".." Then
　　　If (GetAttr(MyPATH & FName) And vbNormal) = vbNormal Then
　　　　With ThisWorkbook
　　　　If cnt > shCount Then
　　　　 Set mySh = .Worksheets.Add(After:=.Worksheets(shCount))
　　　　Else
　　　　 Set mySh = .Worksheets(cnt)
　　　　End If
　　　　Call OpenWordDoc(MyPATH & FName, mySh)
　　　　shCount = ThisWorkbook.Worksheets.Count
　　　　cnt = cnt + 1
　　　　End With
　　　End If
　　End If
　　FName = Dir
　Loop
　objWord.Quit
　Set objWord = Nothing
End Sub
Sub OpenWordDoc(ByVal FName As String, Dest As Worksheet)
　Dim wdDoc As Word.Document
　Dim wdRng As Object
　Dim shName As String
　On Error GoTo ErrHandler
　DoEvents
　Set wdDoc = objWord.Documents.Open(FName, , True)
　wdDoc.Application.ActiveDocument.Repaginate 'documentを読む
　With wdDoc.Application.Selection
　　.Goto What:=wdGoToPage, Which:=wdGoToFirst
　　.EndKey Unit:=wdStory, Extend:=wdExtend
　　.Copy
　End With
　Application.Wait Now() + TimeSerial(0, 0, 1)　　'時間待ちWaiting
　Dest.Range("A1").PasteSpecial
　Dest.Name = wdDoc.Name
　shName = ""
ErrHandler:
　wdDoc.Close False
　Set wdDoc = Nothing
End Sub

この回答へのお礼

ありがとうございます！
今日は試せる時間がありませんでした。。。
今晩か明日か週明けに試してみたいと思います。
これはWordとExcelのどちらのマクロでしょう？

お礼日時：2018/04/13 19:11