wordの表をエクセルに張り付ける
2021年01月09日
Wordで作った表をエクセルに貼り付けようとすると、崩れる。。。
１セルに２行書かれていると、ほかの列がグループ化されるので、
Word VBAを使ってエクセルに貼り付けるマクロを作成。
１セルに２行書かれていると、ほかの列がグループ化されるので、
Word VBAを使ってエクセルに貼り付けるマクロを作成。
【参考ページ】
【コード】Wordの表をExcelにコピペするWordマクロ | みんなのワードマクロ (wordvbalab.com)
Wordファイルにあるすべての表をエクセルの各シートに張り付け。
For tbl = 1 To ActiveDocument.Tables.Count
シート名は、Word表の1行2列目の文字にした。
Set myTable = myDoc.Tables(tbl)
SHname = Left(myTable.Cell(1, 2).Range.Text, Len(myTable.Cell(1, 2).Range.Text) - 2)
（Word表では、セル内の最終2文字は捨てるのが鉄則）
さらにシート名が重複しないように、Wordの表番号を使用。
（Word VBAでエクセルを動かすので、凝った作りにはできず）
最初は行と列のループで作ろうとしたけど、
元々のWordの表が結合されていると、「セルが存在しない！」と怒られる。
てなわけで、表の左上からタブで遷移する仕様で作成。
Do
各処理
各処理
Set objTableCell = objTableCell.Next '次のセルへ（tabと同様）
Loop Until objTableCell Is Nothing
以下ソース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 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
Dim tbl As Long
For tbl = 1 To myDoc.Tables.Count
Set myTable = myDoc.Tables(tbl)
'シートを指定
Set myWorkSheet = myWorkBook.sheets.Add
'-------------------------------------------
'コピペの開始
'-------------------------------------------
Dim objTableCell As Object, SHname As String
' myWorkSheet.Name = Left(myTable.Cell(1, 2).Range.Text, Len(myTable.Cell(1, 2).Range.Text) - 2)
SHname = Left(myTable.Cell(1, 2).Range.Text, Len(myTable.Cell(1, 2).Range.Text) - 2)
myWorkSheet.Name = SHname & "_" & Format(tbl, "00")
Set objTableCell = myTable.Cell(1, 1)
'文字列のコピペ
Do '-- Loop Until objTableCell Is Nothing
i = objTableCell.RowIndex
j = objTableCell.ColumnIndex
myText = myTable.Cell(i, j).Range.Text
myText = Left(myText, Len(myText) - 2)
myText = Replace(myText, vbCr, vbLf)
myWorkSheet.Cells(i, j).Value = myText
Set objTableCell = objTableCell.Next '次のセルへ（tabと同様）
Loop Until objTableCell Is Nothing '------------------------------
' objTableCell.Range.Text = objTableCell.RowIndex & "-" &objTableCell.ColumnIndex
'途中休憩
If i Mod 20 = 0 Then
DoEvents
End If
Next tbl
'-------------------------------------------
'後処理
'-------------------------------------------
'オブジェクト変数の解放
Set myDoc = Nothing
Set myTable = Nothing
Set myWorkBook = Nothing
Set myWorkSheet = Nothing
Set myExcelApp = Nothing
MsgBox "終了しました。"
End Sub
PR
Comment