| |
こんばんは
かなり解らない所ばかりですが、
Sub CopyPasteWordGeneral()
Dim objWord As Object
Dim objWordDoc As Object
Dim WkSht As Worksheet
Dim WkBk As Workbook
Dim myPath As String
Dim MACROBOOK As String
Dim BOOK As String
Dim FName As String
Dim WordFileName As Variant
Dim SHT As String
Dim OPENBOOK As String
Dim r As Range
Dim Judge As Range
Dim SectNum As Long
Dim myCount As Long
Dim SCT As Long
Dim TEXT_LEFT As Integer
Dim TEXT_TOP As Integer
Dim TEXT_SIZE As Integer
Dim RNG As Variant
'
'-------------------------------------------------
' Wordファイルを開く
'-------------------------------------------------
'
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
Set WkSht = ThisWorkbook.Sheets("MENU")
With Application
.AskToUpdateLinks = False
.DisplayAlerts = False
End With 'Application
With WkSht
Set Judge = .Range("A7", .Range("A65536").End(xlUp))
SectNum = WorksheetFunction.Max(.Range("D:D"))
End With 'WkSht
'
'-------------------------------------------------
' コピー＆ペースト
'-------------------------------------------------
'
For Each r In Judge
If r.Value = "end" Then Exit For
If r.Value = 1 And r(1, 8) <> "" Then
FName = r(1, 2).Value
OPENBOOK = ThisWorkbook.Path & "\" & FName
If Len(Dir(OPENBOOK)) = 0 Or FName = "" Then
MsgBox "ファイルが見つかりません！" & FName
Else
Set WkBk = Workbooks.Open(OPENBOOK)
SHT = r(1, 3) ' シート名称
SCT = r(1, 4) ' セクション番号
TEXT_LEFT = r(1, 5) ' 余白横
TEXT_TOP = r(1, 6) ' 余白縦
TEXT_SIZE = r(1, 7) ' スケースサイズ
RNG = r(1, 8) ' セル範囲
With WkBk
If RNG = 1 Then
.Charts(SHT).ChartArea.Copy
Else
.Worksheets(SHT).Range(RNG).Copy
End If
End With 'WkBk
With objWord.Selection
objWordDoc.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
WkBk.Close False
Set WkBk = Nothing
End If
End If
Next r
With Application
.AskToUpdateLinks = True
.DisplayAlerts = True
End With 'Application
objWordDoc.Save
objWordDoc.Close
objWord.Quit
Set objWordDoc = Nothing
Set objWord = Nothing
Set WkSht = Nothing
Set WkBk = Nothing
End Sub
MENUシートのA7からデータの有る最下行までの範囲でA列に「1」が入っていて
同じ行のH列にデータが入っている時に、処理するのでいいですか？
テスト用にコピーしたワードファイルを使って試してみて下さい。
|
|
ウッシ
- 07/4/6(金) 20:39 -
