Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


5914 / 13645 ツリー ←次へ | 前へ→

【48152】開くファイルの制御 tomo 07/4/5(木) 13:18 質問[未読]
【48154】Re:開くファイルの制御 ウッシ 07/4/5(木) 13:53 発言[未読]
【48161】Re:開くファイルの制御 tomo 07/4/5(木) 16:14 お礼[未読]
【48162】Re:開くファイルの制御 ウッシ 07/4/5(木) 16:29 発言[未読]
【48163】Re:開くファイルの制御 tomo 07/4/5(木) 17:31 質問[未読]
【48164】Re:開くファイルの制御 ウッシ 07/4/5(木) 17:42 発言[未読]
【48167】Re:開くファイルの制御 tomo 07/4/5(木) 18:34 お礼[未読]
【48175】Re:開くファイルの制御 tomo 07/4/6(金) 14:04 質問[未読]
【48176】Re:開くファイルの制御 ウッシ 07/4/6(金) 15:24 発言[未読]
【48177】Re:開くファイルの制御 ウッシ 07/4/6(金) 15:42 発言[未読]
【48178】Re:開くファイルの制御 tomo 07/4/6(金) 19:18 発言[未読]
【48179】Re:開くファイルの制御 ウッシ 07/4/6(金) 20:39 発言[未読]
【48221】Re:開くファイルの制御 tomo 07/4/9(月) 9:05 発言[未読]
【48222】Re:開くファイルの制御 ウッシ 07/4/9(月) 9:43 発言[未読]
【48223】Re:開くファイルの制御 tomo 07/4/9(月) 9:48 お礼[未読]
【48235】Re:開くファイルの制御 りん 07/4/9(月) 17:52 発言[未読]
【48251】Re:開くファイルの制御 tomo 07/4/10(火) 8:18 お礼[未読]

【48152】開くファイルの制御
質問  tomo  - 07/4/5(木) 13:18 -

引用なし
パスワード
   度々お世話になっています。
このサイトでは様々な質疑が掲載されており,過去のログでたいていの事は解決できたのですが,今回,見つけきらなかったため質問しました。
よろしくお願いします。

Sub CopyPasteWord()

  Dim objWord As New Word.Application
  Dim WkSht As Worksheet
  Dim BOOK As String

  With Application
    .AskToUpdateLinks = False
    .DisplayAlerts = False

  BOOK = ThisWorkbook.Sheets(1).Cells(12, 2)
  OPENBOOK = ThisWorkbook.Path + "\" + BOOK
  Workbooks.Open OPENBOOK

  wordfilename = Application.GetOpenFilename _
        (Title:="ファイルを開く", _
         FileFilter:="Word 文書(*.doc),*doc")
        '事情によりWordだけGetOpenFilenameメソッドを利用しています
  
  With objWord
    .Visible = True
    .WindowState = wdWindowStateMaximize
    .Documents.Open OPENWORD
  End With

  'ここでExcelからWordにCopyPaste
  'コードは省略します。

    .DisplayAlerts = True
    .AskToUpdateLinks = True
  End With

End Sub

上記のような,コードを作成しました。
既に目的のファイルが開いていた場合についての質問です。
Excelの方は,特に何も起こらないのですが,
Wordの方だけ使用中なるウインドウが表示されてしまいます。
すでにファイルが開いている場合は,IFステートメントでファイルを開く部分のコードを省略するようにしたいのですが,どのようにしたら良いのでしょうか?
(Wordの方もGetOpenFilenameメソッドを使用しないで同様の事を試したのでしたが,結果は一緒でした。)

よろしくお願いします。

【48154】Re:開くファイルの制御
発言  ウッシ  - 07/4/5(木) 13:53 -

引用なし
パスワード
   こんにちは

こんな感じでうまく行くでしょうか?

Sub CopyPasteWord()
  Dim objWord   As Object
  Dim objDoc    As Object
  Dim WkSht    As Worksheet
  Dim BOOK     As String
  Dim wordfilename As Variant
  
  With Application
    .AskToUpdateLinks = False
    .DisplayAlerts = False

'    BOOK = ThisWorkbook.Sheets(1).Cells(12, 2)
'    OPENBOOK = ThisWorkbook.Path & "\" & BOOK
'    Workbooks.Open OPENBOOK
    
    wordfilename = Application.GetOpenFilename _
        (Title:="ファイルを開く", _
         FileFilter:="Word 文書(*.doc),*doc")
        '事情によりWordだけGetOpenFilenameメソッドを利用しています
    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 objDoc = objWord.documents.Open(wordfilename)
    Else
      Set objDoc = GetObject(wordfilename)
    End If
    On Error GoTo 0
    With objWord
      .Visible = True
      .WindowState = 1 'wdWindowStateMaximize
    
    End With

    'ここでExcelからWordにCopyPaste
    'コードは省略します。
  
    objDoc.Close
    objWord.Quit
    
    .DisplayAlerts = True
    .AskToUpdateLinks = True
  End With
  Set objWord = Nothing
  Set objDoc = Nothing
End Sub

【48161】Re:開くファイルの制御
お礼  tomo  - 07/4/5(木) 16:14 -

引用なし
パスワード
   ▼ウッシ さん:
返信いただき,ありがとうございました。
まさに,理想通りです。

見慣れないものも色々あるようなので,あまり使用したことがない「On Errorステートメント」も含め,これから調べて今後に生かしたいと思います。

ありがとうございました。

【48162】Re:開くファイルの制御
発言  ウッシ  - 07/4/5(木) 16:29 -

引用なし
パスワード
   こんにちは

指定したワード文書以外が開いていると最後は一緒に閉じてしまっていますので適宜修正
して下さい。

【48163】Re:開くファイルの制御
質問  tomo  - 07/4/5(木) 17:31 -

引用なし
パスワード
   ▼ウッシ さん:
>こんにちは
>
>指定したワード文書以外が開いていると最後は一緒に閉じてしまっていますので適宜修正
>して下さい。
ありがとうございます。気づいたので修正しました。


主題は解決したのですが,別の問題が発生しました。再度,教えてください。

例えば,開くExcelブック名を間違えてセルに記入した場合,当然,エラーが出るのですが,これを正しく修正し,再度,マクロを実行させると「実行時エラー '462'」が出てしまいます。
一度,ブックを終了してから再び実行すると問題なく流れます。
マイ ドキュメント内で作業しているため,サーバーとのアクセスは関係ないのですが,どういうことなのでしょうか?

一部のコード(Wordに貼付部)ですが,

With objWord.Selection
  .ParagraphFormat.Alignment = wdAlignParagraphLeft
  With .Font
    .Size = 12
    .Name = "MS ゴシック"
  End With
  .PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
      Placement:=wdFloatOverText, DisplayAsIcon:=False
  .ShapeRange.RelativeHorizontalPosition = _
    wdRelativeHorizontalPositionMargin
  .ShapeRange.RelativeVerticalPosition = _
    wdRelativeVerticalPositionMargin
  .ShapeRange.ScaleWidth TEXT_SIZE, True 'TEXT_SIZEはセルから取得しています。
  .ShapeRange.ScaleHeight TEXT_SIZE, True
  .ShapeRange.Left = MillimetersToPoints(TEXT_LEFT) 'TEXT_LEFTもセルから取得しています。
      '↑ ここで,止まってしまいます。
  .ShapeRange.Top = MillimetersToPoints(TEXT_TOP) 'TEXT_TOPもセルから取得しています。
  .MoveLeft
End With

よろしくお願いします。(必要でしたら全コード記述します)

【48164】Re:開くファイルの制御
発言  ウッシ  - 07/4/5(木) 17:42 -

引用なし
パスワード
   こんにちは

その処理の前後のコードでエラー時の処理をきちんと入れてみて下さい。

Sub CopyPasteWord()
  Dim objWord   As Object
  Dim objDoc    As Object
  Dim WkBook    As Workbook
  Dim WkSht    As Worksheet
  Dim BOOK     As String
  Dim wordfilename As Variant
  Dim OPENBOOK   As String
  
  BOOK = ThisWorkbook.Sheets(1).Cells(12, 2)
  OPENBOOK = ThisWorkbook.Path & "\" & BOOK & ".xls"
  If Len(Dir(OPENBOOK)) = 0 Then Exit Sub
  
  With Application
    .AskToUpdateLinks = False
    .DisplayAlerts = False
  
    Set WkBook = Workbooks.Open(OPENBOOK)
    
    wordfilename = Application.GetOpenFilename _
        (Title:="ファイルを開く", _
         FileFilter:="Word 文書(*.doc),*doc")
        '事情によりWordだけGetOpenFilenameメソッドを利用しています
    If VarType(wordfilename) = vbBoolean Then
      WkBook.Close False
      Set WkBook = Nothing
      Exit Sub
    End If
    
    On Error Resume Next
    Set objWord = GetObject(, "Word.Application")
    If objWord Is Nothing Then
      Set objWord = CreateObject("Word.Application")
      Set objDoc = objWord.documents.Open(wordfilename)
    Else
      Set objDoc = GetObject(wordfilename)
    End If
    On Error GoTo 0
    With objWord
      .Visible = True
      .WindowState = 1 'wdWindowStateMaximize
    
    End With

    Set WkSht = WkBook.Worksheets(1)

    'ここでExcelからWordにCopyPaste
    'コードは省略します。
  
    objDoc.Close
    objWord.Quit
    
    .DisplayAlerts = True
    .AskToUpdateLinks = True
  End With
  Set objWord = Nothing
  Set objDoc = Nothing
  Set WkBook = Nothing
  Set WkSht = Nothing
End Sub

【48167】Re:開くファイルの制御
お礼  tomo  - 07/4/5(木) 18:34 -

引用なし
パスワード
   ▼ウッシ さん:
>こんにちは
>
>その処理の前後のコードでエラー時の処理をきちんと入れてみて下さい。
>
On Error ステートメントを利用するわけですね。
挑戦してみます。
ありがとうございました。

【48175】Re:開くファイルの制御
質問  tomo  - 07/4/6(金) 14:04 -

引用なし
パスワード
   ▼tomo さん:
>▼ウッシ さん:
>>こんにちは
>>
>>その処理の前後のコードでエラー時の処理をきちんと入れてみて下さい。
>>
>On Error ステートメントを利用するわけですね。
>挑戦してみます。
>ありがとうございました。

度々,申し訳ありません。再度,教えてください。
下記のようにOn Errorステートメントを利用してエラーを無効にすることはできたのですが,なぜか,TEXT_LEFT 及び TEXT_TOP で所得した位置に貼り付けことができません。(移動前のデフォルトの位置である左上のままです)
On Errorステートメントの使い方がだめなのでしょうか?
それとも別の原因なのでしょうか?

With objWord.Selection
  .ParagraphFormat.Alignment = wdAlignParagraphLeft
  With .Font
    .Size = 12
    .Name = "MS ゴシック"
  End With
  .PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
      Placement:=wdFloatOverText, DisplayAsIcon:=False
  .ShapeRange.RelativeHorizontalPosition = _
    wdRelativeHorizontalPositionMargin
  .ShapeRange.RelativeVerticalPosition = _
    wdRelativeVerticalPositionMargin
  .ShapeRange.ScaleWidth TEXT_SIZE, True
                  'TEXT_SIZEはセルから取得しています。
  .ShapeRange.ScaleHeight TEXT_SIZE, True
  On Error Resume Next
  If TEXT_LEFT <> "" Then
    .ShapeRange.Left = MillimetersToPoints(TEXT_LEFT)
                  'TEXT_LEFTもセルから取得しています。
    .ShapeRange.Top = MillimetersToPoints(TEXT_TOP)
                  'TEXT_TOPもセルから取得しています。
  End If
  On Error Goto 0
  .MoveLeft
End With

よろしくお願いします。

【48176】Re:開くファイルの制御
発言  ウッシ  - 07/4/6(金) 15:24 -

引用なし
パスワード
   こんにちは

>例えば,開くExcelブック名を間違えてセルに記入した場合,当然,エラーが出るの
>ですが,これを正しく修正
問題はこちらの部分で、存在しないファイ名だった場合や、全く対象でないファイルを
指定してしまった時に、きちんとマクロを終わらせるようにして下さいという意味の
コードを前回は提示しました。
エラーで強制終了したままですとWordのインスタンス等が残ってる場合が発生するかも
知れません。

下記のような感じで試してエラーの際にどのようなエラーメッセージが表示されるのか
提示して下さい。
またその時のイミディエイトウィンドウの「TEXT_LEFT」及び「TEXT_TOP」の値が
どうなっているのか調べて下さい。

Sub CopyPasteWord_1()
  Dim objWord   As Object
  Dim objDoc    As Object
  Dim WkBook    As Workbook
  Dim WkSht    As Worksheet
  Dim BOOK     As String
  Dim wordfilename As Variant
  Dim OPENBOOK   As String
  
  BOOK = ThisWorkbook.Sheets(1).Cells(12, 2)
  OPENBOOK = ThisWorkbook.Path & "\" & BOOK & ".xls"
  If Len(Dir(OPENBOOK)) = 0 Then Exit Sub
  
  With Application
    .AskToUpdateLinks = False
    .DisplayAlerts = False
  
    Set WkBook = Workbooks.Open(OPENBOOK)
    
    wordfilename = Application.GetOpenFilename _
        (Title:="ファイルを開く", _
         FileFilter:="Word 文書(*.doc),*doc")
        '事情によりWordだけGetOpenFilenameメソッドを利用しています
    If VarType(wordfilename) = vbBoolean Then
      WkBook.Close False
      Set WkBook = Nothing
      Exit Sub
    End If
    
    On Error Resume Next
    Set objWord = GetObject(, "Word.Application")
    If objWord Is Nothing Then
      Set objWord = CreateObject("Word.Application")
      Set objDoc = objWord.documents.Open(wordfilename)
    Else
      Set objDoc = GetObject(wordfilename)
    End If
    On Error GoTo 0
    
    With objWord
      .Visible = True
      .WindowState = 1 'wdWindowStateMaximize
    
    End With

    Set WkSht = WkBook.Worksheets(1)
    
    'コードは省略します。

    'ここでExcelからWordにCopyPaste
    With objWord.Selection
      .ParagraphFormat.Alignment = wdAlignParagraphLeft
      With .Font
        .Size = 12
        .Name = "MS ゴシック"
      End With
      .PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
          Placement:=wdFloatOverText, DisplayAsIcon:=False
      .ShapeRange.RelativeHorizontalPosition = _
        wdRelativeHorizontalPositionMargin
      .ShapeRange.RelativeVerticalPosition = _
        wdRelativeVerticalPositionMargin
      .ShapeRange.ScaleWidth TEXT_SIZE, True
                      'TEXT_SIZEはセルから取得しています。
      .ShapeRange.ScaleHeight TEXT_SIZE, True
      
      Debug.Print "TEXT_LEFT=" & TEXT_LEFT & " :: TEXT_TOP=" & TEXT_TOP      
      If TEXT_LEFT <> "" Then
        .ShapeRange.Left = MillimetersToPoints(TEXT_LEFT)
                      'TEXT_LEFTもセルから取得しています。
        .ShapeRange.Top = MillimetersToPoints(TEXT_TOP)
                      'TEXT_TOPもセルから取得しています。
      End If
      
      .MoveLeft
    End With
      
    'コードは省略します。
      
      
    objDoc.Close
    If objWord.document.Count = 0 Then
      objWord.Quit
    End If
    
    WkBook.Close
    
    .DisplayAlerts = True
    .AskToUpdateLinks = True
  End With
  Set objWord = Nothing
  Set objDoc = Nothing
  Set WkBook = Nothing
  Set WkSht = Nothing
End Sub

【48177】Re:開くファイルの制御
発言  ウッシ  - 07/4/6(金) 15:42 -

引用なし
パスワード
   ちょっと訂正です。

    If objWord.document.Count = 0 Then

    If objWord.documents.Count = 0 Then
に。

あと、
   If TEXT_LEFT <> "" Then
ですが、
TEXT_LEFTの変数の型はなんでしょうか?

数値なら、
   If TEXT_LEFT <> 0 Then
とかにしないと、それだけでもエラーになりますよ。

【48178】Re:開くファイルの制御
発言  tomo  - 07/4/6(金) 19:18 -

引用なし
パスワード
   ▼ウッシ さん:

「実行時エラー '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 = "MS ゴシック"
          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

【48179】Re:開くファイルの制御
発言  ウッシ  - 07/4/6(金) 20:39 -

引用なし
パスワード
   こんばんは

かなり解らない所ばかりですが、

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 = "MS ゴシック"
          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列にデータが入っている時に、処理するのでいいですか?

テスト用にコピーしたワードファイルを使って試してみて下さい。

【48221】Re:開くファイルの制御
発言  tomo  - 07/4/9(月) 9:05 -

引用なし
パスワード
   ▼ウッシ さん:
おはようございます。
変身が遅くなり失礼しました。

提示いただいたコードで試しましたが,やはり同じところでエラーが発生します。
デバックの値も正しい値を示しているのですが・・・

もう一度整理しますと,
例えば,ファイル名の記入を間違え,一度エラーで止まり,正しいファイル名に直す等,1回エラーが起きた場合の再Runのみ場合に発生するエラーであり,「実行時エラー '462'」となります。

お手数ですが,よろしくお願いいたします。

【48222】Re:開くファイルの制御
発言  ウッシ  - 07/4/9(月) 9:43 -

引用なし
パスワード
   こんにちは

>例えば,ファイル名の記入を間違え,一度エラーで止まり,正しいファイル名に直す等
>1回エラーが起きた場合の再Runのみ場合に発生するエラー
に惑わされてました。

              .Left = MillimetersToPoints(TEXT_LEFT)
              .Top = MillimetersToPoints(TEXT_TOP)



              .Left = objWord.MillimetersToPoints(TEXT_LEFT)
              .Top = objWord.MillimetersToPoints(TEXT_TOP)

とすると、どうなりますか?

【48223】Re:開くファイルの制御
お礼  tomo  - 07/4/9(月) 9:48 -

引用なし
パスワード
   ▼ウッシ さん:
こんにちは
>              .Left = MillimetersToPoints(TEXT_LEFT)
>              .Top = MillimetersToPoints(TEXT_TOP)
>を
>              .Left = objWord.MillimetersToPoints(TEXT_LEFT)
>              .Top = objWord.MillimetersToPoints(TEXT_TOP)
>
>とすると、どうなりますか?

エラーが起きなくなりました!!
Wordと認識されていなかったということなのでしょうか?

おかげさまで無事解決できました。
丁寧にご説明いただき,大変ありがとうございました。

【48235】Re:開くファイルの制御
発言  りん E-MAIL  - 07/4/9(月) 17:52 -

引用なし
パスワード
   tomo さん、こんばんわ。

>>              .Left = MillimetersToPoints(TEXT_LEFT)
>>              .Top = MillimetersToPoints(TEXT_TOP)
>>を
>>              .Left = objWord.MillimetersToPoints(TEXT_LEFT)
>>              .Top = objWord.MillimetersToPoints(TEXT_TOP)
>>
>Wordと認識されていなかったということなのでしょうか?

解決後ですが、ちょっと説明だけ。
objWordを省略した場合、
(Application.)MillimetersToPoints(TEXT_TOP)
 ↑となるのですが、
ExcelのApplicationオブジェクトにはMillimetersToPointsというメソッドがないのでエラーになります。

エクセルApplicationのメンバーなのは、
 InchesToPoints
 CentimetersToPoints
この二つです。

【48251】Re:開くファイルの制御
お礼  tomo  - 07/4/10(火) 8:18 -

引用なし
パスワード
   りん さん,こんにちは。

>objWordを省略した場合、
>(Application.)MillimetersToPoints(TEXT_TOP)
> ↑となるのですが、
>ExcelのApplicationオブジェクトにはMillimetersToPointsというメソッドがないのでエラーになります。
>
>エクセルApplicationのメンバーなのは、
> InchesToPoints
> CentimetersToPoints
>この二つです。

ご説明ありがとうございました。
勉強になりました。

5914 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free