[[20151216165255]]　『同じシート名を有する別ブックへのデータ転記』（zunzun）　ページの最後に飛ぶ

『同じシート名を有する別ブックへのデータ転記』（zunzun）

同じフォルダにsWBとdWBの2つのブックがあります。dWBのシート名（データ）のA6から下方にシート名が記載され、その名前と同じシートが複数あります。sWBの各シートのA1：AW8のデータをコピーして、dWBの同じシートのA1に図として貼り付けるマクロを組みたく、以下のマクロを作成しましたが、 'コピー元のブックを開く　で止まってしまいます。なお、図として貼付けにはなっていません。これが解決したら修正します。
どこに問題があるのでしょうか？よろしくお願いします。

Sub 図貼付け()

    Dim sFile As String
    Dim sWB As Workbook
    Dim dWB As Workbook
    Dim sname As String
    Dim i As Long
    Dim lr As Long
    Const SOURCE_DIR As String = "C:\Users\Desktop\H27点検\"

    Application.ScreenUpdating = False

    '指定したフォルダ内にあるブックのファイル名を取得
    sFile = Dir(SOURCE_DIR & "H27調書集計データシート.xlsm")

    'フォルダ内にブックがなければ終了
    If sFile = "" Then Exit Sub

    '貼付けブックの数を取得
    lr = Cells(Rows.Count, 1).End(xlUp).row

     Set dWB = ThisWorkbook

     For i = 6 To lr

   '貼付けブックのシート名を取得
     sname = ActiveSheet.Cells(i, 1)

   'コピー元のブックを開く
     Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)

    'コピー元のシート名の範囲を集約用ブックの同じシート名にコピー
    dWB.Worksheets(sname).Range("a1").Value = sWB.Worksheets(sname).Range("a1:aw8").Value

   Next

   'コピー元ファイルを閉じる
    sWB.Close

    '集約用ブックを保存して閉じる
    dWB.Close SaveChanges:=True

    Application.ScreenUpdating = False

End Sub

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

ファイルのパスが間違っているのでは？
"C:\Users\Desktop\H27点検\"
　　↓
"C:\Users\ここにユーザー名が入っているはず\Desktop\H27点検\"
（???） 2015/12/16(水) 17:27

？？？さんありがとうございます。そこは、名前なので、抜いて質問しました。
（Zunzun） 2015/12/16(水) 18:24

 >>'コピー元のブックを開く　で止まってしまいます

 具体的にはどういう現象なのでしょうか？

 ・何かエラーが発生？
 ・エクセルが固まって、うんともすんともいわない？

 前者ならエラー番号とメッセージ内容を教えてください。

（β） 2015/12/16(水) 18:42

βさんありがとうございます。sWBファイルは、既に開いています。2重に開きますか？と表示され、いいえを選んだあとに、コピー元のブックを開くの構文が黄色く表示されます。エラーメッセージは出ていません。
（Zunzun） 2015/12/16(水) 19:03

 ということはメッセージ通り、すでに　H27調書集計データシート.xlsm　が開かれているということです。
 （同じフォルダにあったものかどうかはわかりませんが）

 対処方法は

 １．マクロ実行前に、操作で、H27調書集計データシート.xlsm　を閉じる。
 ２．マクロ内で、H27調書集計データシート.xlsm　が開かれているかどうかを判定し、開かれていれば、開かずに、それを使う。
 ３．マクロ内で、H27調書集計データシート.xlsm　が開かれているかどうかを判定し、開かれていれば、それを閉じたうえで開きなおす

 いずれかでしょうね。

（β） 2015/12/16(水) 19:20

βさんありがとうございます。明日、出社して修正してみます。ただ、ご指摘の1.については、閉じてからマクロを実行しましたが、先の表示が出ていたと記憶しています。
（Zunzun） 2015/12/16(水) 19:57

βさん　おはようございます。出来ました！！　下の構文に修正（ファイルを閉じてからNEXTを入れました）しました。ありがとうございました。

'コピー元のブックを開く

     Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)

    'コピー元のシート名の範囲を集約用ブックの同じシート名にコピー
    dWB.Worksheets(sname).Range("a1").Value = sWB.Worksheets(sname).Range("a1:aw8").Value

   'コピー元ファイルを閉じる
    sWB.Close SaveChanges:=False

   Next
（zunzun） 2015/12/17(木) 09:07

 もう見ないかもしれませんが・・・

 最初のコードをよく見ていませんでした。
 ループ内でブックを開いていたんですね。

 で、そちらの対応、エラーは回避できますけど、感心しません。

 ループの前に　開く

 シートのループ処理

 ループが終わったらブックを閉じる

 このようにすべきですよ。毎回開いて、閉じて、・・・　無駄ですね。

（β） 2015/12/17(木) 09:30

βさん　ありがとうございます。修正しました。
（zunzun） 2015/12/17(木) 09:53

数値を転記するマクロは上手く動くようになりましたが、図として貼り付けるように
'コピー元のシート名の範囲を貼付けブックの同じシート名に図として貼付けを

 dWB.Worksheets(sname).Range("a1:d8").Value = sWB.Worksheets(sname).Range("a1:d8").Value
から
 sWB.Worksheets(sname).Range("a1:aw8").CopyPicture _
        Appearance:=xlScreen, Format:=xlPicture
     dWB.Worksheets(sname).Range("a1").Select
       ActiveSheet.Paste
 に変更すると、RangeクラスのSelectメソッドが失敗しました。と表示され  dWB.Worksheets(sname).Range("a1").Select
が黄色表示になります。解決策を教えていただけないでしょうか？

Sub 図貼付け2()

    Dim sFile As String
    Dim sWB As Workbook
    Dim dWB As Workbook
    Dim sname As String
    Dim i As Long
    Dim lr As Long
    Const SOURCE_DIR As String = "C:\Users\c081327\Desktop\H27点検\"

    Application.ScreenUpdating = False

    '指定したフォルダ内にあるブックのファイル名を取得
    sFile = Dir(SOURCE_DIR & "H27調書集計データシート.xlsm")

    'フォルダ内にブックがなければ終了
    If sFile = "" Then Exit Sub

    '貼付けブックの数を取得
    lr = Cells(Rows.Count, 1).End(xlUp).row

     Set dWB = ThisWorkbook

      'コピー元のブックを開く
     Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)

     For i = 6 To lr

   '貼付けブックのシート名を取得
     sname = dWB.ActiveSheet.Cells(i, 1)

    'コピー元のシート名の範囲を貼付けブックの同じシート名に図として貼付け
    sWB.Worksheets(sname).Range("a1:aw8").CopyPicture _
        Appearance:=xlScreen, Format:=xlPicture
     dWB.Worksheets(sname).Range("a1").Select
       ActiveSheet.Paste

   Next

   'コピー元ファイルを閉じる
    sWB.Close SaveChanges:=False

    Application.ScreenUpdating = False

End Sub
（zunzun） 2015/12/17(木) 11:27

出来ました。.Activateを追加して解決しました。ありがとうございました。

Sub 図貼付け2()

    Dim sFile As String
    Dim sWB As Workbook
    Dim dWB As Workbook
    Dim sname As String
    Dim i As Long
    Dim lr As Long
    Const SOURCE_DIR As String = "C:\Users\c081327\Desktop\H27点検\"

    Application.ScreenUpdating = False

    '指定したフォルダ内にあるブックのファイル名を取得
    sFile = Dir(SOURCE_DIR & "H27調書集計データシート.xlsm")

    'フォルダ内にブックがなければ終了
    If sFile = "" Then Exit Sub

    '貼付けブックを橋数を取得
    lr = Cells(Rows.Count, 1).End(xlUp).row

     Set dWB = ThisWorkbook

      'コピー元のブックを開く
     Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)

     For i = 6 To lr

   '貼付けブックのシート名を取得
     sname = dWB.Worksheets("データ").Cells(i, 1)

    'コピー元のシート名の範囲を貼付けブックの同じシート名に図として貼付け
    sWB.Worksheets(sname).Range("a1:aw8").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    dWB.Worksheets(sname).Activate
    Range("a1").Select
       ActiveSheet.Paste

   Next

   'コピー元ファイルを閉じる
    sWB.Close SaveChanges:=False

    Application.ScreenUpdating = False

End Sub
（zunzun） 2015/12/17(木) 12:52

 再び、もう見ないかなぁと案じつつ。

 エラー回避という意味では、Activate手当てでＯＫですが、ワークシート.Paste　メソッドで
 転記先の指定が可能です。そうしておけば目的のシート、セルをアクティブにする必要はなくなります。

    dWB.Worksheets(sname).Paste dWB.Worksheets(sname).Range("A1")

（β） 2015/12/17(木) 16:26

βさんありがとうございます。修正してみます。
（Zunzun） 2015/12/17(木) 23:08

コメント返信：

[ 一覧(最新更新順) ]

[[20151216165255]] 『同じシート名を有する別ブックへのデータ転記』（zunzun） ページの最後に飛ぶ

[[20151216165255]]　『同じシート名を有する別ブックへのデータ転記』（zunzun）　ページの最後に飛ぶ