WordからExcelへ変換しデータを揃える方法は？

試しにコードを書いてみました。Excel VBA です。 DOC ファイル内の全ての表を Excel のアクティブシートに行列を入れ替えて 書き出します。ただ、複合表があると、期待どおりの結果は得られないと思い ます。 Word VBA には結合セルを調べるプロパティーがない？ みたいなので、無理矢理 やってますが、一応それなりに動くようです。 また、エラートラップもほとんどしてません。試してみて、エラー終了したら タスクマネージャで WINWORD.EXE が残っていないか確認して下さい。 使い方は Excel の 標準モジュールに貼り付け、VBE [ツール]-[参照設定]で ・Microsoft Word x.x Object Lybrary をチェックしてから実行します。x.x はお使いの OFFICE のバージョンにより 異なります。 少しは役立つかな？　と思ったけど、あんまり役立たない気がしますm(_ _;)m Sub Sample() 　　Dim WRD　　　　 As Word.Application 　　Dim DOC　　　　 As Word.Document 　　Dim objTable　　As Word.Table 　　Dim objCell　　 As Word.Cell 　　Dim strFilename As String 　　Dim strText　　 As String 　　Dim lngRows　　 As Long 　　Dim lngCols　　 As Long 　　Dim Buffer()　　As String 　　Dim R　　　　　 As Long 　　Dim C　　　　　 As Long 　　Const MARK　　　As String = "$$$$" 　　' DOCファイルの指定 　　strFilename = Application.GetOpenFilename("WORDファイル (*.doc), *.doc") 　　If UCase$(strFilename) = "FALSE" Then 　　　　Exit Sub 　　End If 　　' DOCファイルオープン 　　Application.StatusBar = "[ " & Dir(strFilename) & " ]を開いてます..." 　　Set WRD = New Word.Application 　　WRD.Visible = False ' True の方がいいかも？ 　　Set DOC = WRD.Documents.Open(strFilename) 　　' テーブルのコピー＆ペースト 　　Application.StatusBar = "テーブルをコピー中..." 　　For Each objTable In DOC.Tables 　　　　' テーブルサイズを求めてバッファ領域を確保 　　　　With objTable 　　　　　　lngRows = .Rows.Count 　　　　　　lngCols = .Columns.Count 　　　　End With 　　　　ReDim Buffer(1 To lngRows, 1 To lngCols) 　　　　' セル内改行コードを置換しながらバッファ 　　　　For R = 1 To lngRows 　　　　　　For C = 1 To lngCols 　　　　　　　　' 結合セルがあると次行でエラーになります、、、 On Error GoTo ERROR_SKIP 　　　　　　　　strText = objTable.Cell(R, C).Range.Text 　　　　　　　　strText = Replace(strText, Chr(13), MARK) 　　　　　　　　strText = Left$(strText, Len(strText) - Len(MARK) - 1) 　　　　　　　　Buffer(R, C) = strText ERROR_SKIP: 　　　　　　Next C 　　　　Next R 　　　　 　　　　' 行列をスワップさせてアクティブシートに転記 　　　　With ActiveSheet.Range("A65536").End(xlUp).Offset(1) _ 　　　　　　.Resize(UBound(Buffer, 2), UBound(Buffer)) 　　　　　　' 文字列として転記しないなら次行をコメントアウト 　　　　　　.NumberFormatLocal = "@" 　　　　　　' 一括転記(Transpose で行列を入れ替えてます） 　　　　　　.Value = Application.Transpose(Buffer) 　　　　　　' セル内の改行コードを元に戻す 　　　　　　.Replace What:=MARK, Replacement:=vbLf 　　　　End With 　　Next objTable 　　' WORD フィイルを閉じてアプリケーションを開放 　　Application.StatusBar = "[ " & Dir(strFilename) & " ]を閉じています..." 　　DOC.Close SaveChanges:=False 　　Set DOC = Nothing 　　Application.StatusBar = "" 　　WRD.Quit 　　Set WRD = Nothing End Sub