| |
▼ウッシ さん：
「実行時エラー '462'
ﾘﾓｰﾄｻｰﾊﾞがないか、使用できる状態ではありません。」
とメッセージが出ます。
TEXT_LEFT = Cells(7, 5) = 8
TEXT_TOP = Cells(7, 6) = 20
であり，イミディエイトウィンドウには
「TEXT_LEFT=8 :: TEXT_TOP=20」と表示されています。
値としては問題ないのですが･･･
Forスーテトメントで繰り返し作業を行っている影響なのでしょうか？
長くなってしまいますが，全文を記載します。
大変ご面倒をおかけしますが，よろしくお願いします。
Option Explicit
Dim objWord As Object, objWordDoc As Object
Dim WkSht As Worksheet
Dim WkBk As Workbook
Dim myPath As String, MACROBOOK As String, BOOK As String, _
FName As String, WordFileName As String, SHT As String, _
OPENBOOK As String
Dim Judge As Integer, SectNum As Integer, myCount As Integer, _
SCT As Integer, TEXT_LEFT As Integer, TEXT_TOP As Integer, _
TEXT_SIZE As Integer
Dim i As Integer, j As Integer, n As Integer
Dim RNG As Variant
Sub CopyPasteWordGeneral()
i = 1
n = 6
'
'-------------------------------------------------
' Wordファイルを開く
'-------------------------------------------------
'
Set WkSht = ThisWorkbook.Sheets("MENU")
With Application
.AskToUpdateLinks = False
.DisplayAlerts = False
End With 'Application
WkSht.Activate
Judge = WorksheetFunction.CountIf(Range("A:A"), 1)
SectNum = WorksheetFunction.Max(Range("D:D"))
WordFileName = Application.GetOpenFilename _
(Title:="ファイルを開く", _
FileFilter:="Word 文書(*.doc),*doc")
If VarType(WordFileName) = vbBoolean Then Exit Sub
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
Set objWord = CreateObject("Word.Application")
Set objWordDoc = objWord.Documents.Open(WordFileName)
Else
Set objWordDoc = GetObject(WordFileName)
End If
On Error GoTo 0
With objWord
.Visible = True 'Wordの表示
.WindowState = 1 'wdWindowStateMaximize, 表示最大化
End With 'objWord
'
'-------------------------------------------------
' コピー＆ペースト
'-------------------------------------------------
'
With WkSht
For j = 1 To Judge
If .Cells(i + n, 1) = "end" Then Exit Sub
If .Cells(i + n, 8) = "" Then
j = j - 1
GoTo KAIGYO
End If
If .Cells(i + n, 1) = 1 Then
If .Cells(i + n, 2) <> "" Then
FName = .Cells(i + n, 2)
BOOK = FName
OPENBOOK = ThisWorkbook.Path + "\" + BOOK
Workbooks.Open OPENBOOK
If Len(Dir(OPENBOOK)) = 0 Then
MsgBox "ファイルが見つかりません！"
Exit Sub
End If
Else
BOOK = FName
End If
SHT = .Cells(i + n, 3) ' シート名称
SCT = .Cells(i + n, 4) ' セクション番号
TEXT_LEFT = .Cells(i + n, 5) ' 余白横
TEXT_TOP = .Cells(i + n, 6) ' 余白縦
TEXT_SIZE = .Cells(i + n, 7) ' スケースサイズ
RNG = .Cells(i + n, 8) ' セル範囲
Set WkBk = Workbooks(BOOK)
With WkBk
If RNG = 1 Then
.Charts(SHT).ChartArea.Copy
Else
.Worksheets(SHT).Range(RNG).Copy
End If
End With 'WkBk
With objWord.Selection
objWord.Documents(WordFileName).Activate
myCount = objWordDoc.Sections.Count
.EndKey Unit:=wdStory 'Word最終セクションに移動
If SectNum > myCount Then
While SectNum <> myCount 'セクション数の追加制御
.InsertBreak Type:=wdSectionBreakNextPage
myCount = objWordDoc.Sections.Count
Wend
End If
objWordDoc.Range(Start:=objWordDoc.Sections _
(SCT).Range.End - 1, _
End:=objWordDoc.Sections _
(SCT).Range.End - 1).Select
.ParagraphFormat.Alignment = wdAlignParagraphLeft
With .Font
.Size = 12
.Name = "ＭＳ ゴシック"
End With '.Font
.PasteSpecial Link:=False, _
DataType:=wdPasteEnhancedMetafile, _
Placement:=wdFloatOverText, _
DisplayAsIcon:=False '図（拡張ﾒﾀﾌｧｲﾙ）で貼付
With .ShapeRange
.RelativeHorizontalPosition = _
wdRelativeHorizontalPositionMargin
.RelativeVerticalPosition = _
wdRelativeVerticalPositionMargin
.ScaleWidth TEXT_SIZE, True
.ScaleHeight TEXT_SIZE, True
Debug.Print "TEXT_LEFT=" & TEXT_LEFT & " :: _
TEXT_TOP=" & TEXT_TOP
'On Error Resume Next
If TEXT_TOP <> 0 Then
.Left = MillimetersToPoints(TEXT_LEFT)
.Top = MillimetersToPoints(TEXT_TOP)
End If
'On Error GoTo 0
End With
.MoveLeft
Application.CutCopyMode = False
End With 'objWord.Selection
ThisWorkbook.Activate
Else
j = j - 1
End If
KAIGYO:
i = i + 1
Set WkBk = Nothing
Next j
End With 'WkSht
With Application
.AskToUpdateLinks = True
.DisplayAlerts = True
End With 'Application
Set objWord = Nothing
Set objWordDoc = Nothing
Set WkSht = Nothing
Set WkBk = Nothing
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 07/4/9(月) 17:52 -
