Option Explicit
'[ツール] → [参照設定] → [Microsoft Word XX.X Object Library]をチェック → [OK]
Sub OpenDoc()
Dim app As New Word.Application
app.Visible = True
'Documentを開く
Dim doc As Word.Document
Set doc = app.Documents.Open("C:\Users\kazuya\Desktop\folder1" & "\" & "sdxs.docx")
'doc.Windows(1).Visible = False
'Set app = Nothing 'オブジェクトを開放
End Sub
Sub DocsVisible()
Dim doc As Word.Document
Dim docs As Word.Documents
Set docs = GetDocsOpen
If docs Is Nothing Then Exit Sub
For Each doc In docs
doc.Windows(1).Visible = True
Next
End Sub
Sub ReadWordToSheet()
Dim i As Integer, p As Long, cnt As Integer
Dim doc As Word.Document, docs As Word.Documents
Dim para As Word.Paragraph, table As Word.table
Dim shThis As Worksheet
Dim ceOutPara As Range, ceOutTable As Range
Dim txt As String
Set shThis = ActiveSheet
Set docs = GetDocsOpen
If docs Is Nothing Then Exit Sub
Set doc = docs(1)
shThis.Cells.Clear
Set ceOutPara = shThis.Cells(2, 2)
Set ceOutTable = shThis.Cells(2, 6)
Application.ScreenUpdating = False
p = 1
ceOutPara.Value = "Paragraph"
For Each para In doc.Paragraphs
If para.Range.Information(wdWithInTable) = False Then
ceOutPara.Offset(p, 0).Value = p
txt = para.Range.Text
If Left(txt, 1) = Chr(10) Or Left(txt, 1) = Chr(13) Then
ceOutPara.Offset(p, 1).Value = ""
Else
ceOutPara.Offset(p, 1).Value = para.Range.Text
End If
p = p + 1
End If
If p > 1000 Then Exit For
Next
cnt = 0
For Each table In doc.Tables
cnt = cnt + 1
ceOutTable.Value = "Table" & cnt
table.Range.Copy
ceOutTable.Offset(1, 0).Select
shThis.PasteSpecial Format:="HTML", NoHTMLFormatting:=True
For i = 1 To 50
Set ceOutTable = ceOutTable.Offset(0, 1)
If ceOutTable.End(xlDown).Row >= 1000 Then
Set ceOutTable = ceOutTable.Offset(0, 1)
Exit For
End If
Next i
Next table
Application.ScreenUpdating = True
End Sub
Sub WordOpe()
'Wordを立ち上げ
Dim app As New Word.Application
app.Visible = True
'Documentを開く
Dim doc As Word.Document
Set doc = app.Documents.Open(ThisWorkbook.Path & "\" & "word1.docx")
Set app = Nothing 'オブジェクトを開放
End Sub
Function GetDocsOpen() As Word.Documents
Dim app As New Word.Application
On Error GoTo Label1
Set app = GetObject(Class:="Word.Application")
Set GetDocsOpen = app.Documents
Set app = Nothing
Exit Function
Label1:
Set GetDocsOpen = Nothing
Set app = Nothing
End Function
Function GetDocParas(doc As Word.Document) As String()
Dim para As Word.Paragraph
Dim p As Integer
Dim pMax As Integer
pMax = 1000
ReDim aryPara(1 To pMax) As String
p = 0
For Each para In doc.Content.Paragraphs
p = p + 1
aryPara(p) = para.Range.Text
If p > pMax Then Exit For
Next
ReDim Preserve aryPara(1 To p)
GetDocParas = aryPara
Set para = Nothing
End Function