[[20081119075059]]　『ファイルを検索してマクロ実行』（ミンミンゼミ）　ページの最後に飛ぶ

『ファイルを検索してマクロ実行』（ミンミンゼミ）

 同一フォルダ内に，Ａ，Ｂ，Ｃの３つのファイルがあります。
 そこへ任意のＡ，Ｂ，Ｃ以外の名前のファイルを貼り付けます。
 そこで，下記のようなＶＢＡコードをＡファイルに作りたいのですが
 できますでしょうか。

 Ｓｕｂ

 　フォルダ内に，Ａ，Ｂ，Ｃ以外のファイルが見つからなかったら
 　マクロを実行しない

 　Ａ，Ｂ，Ｃ以外のファイルが見つかったら，マクロを実行

 　以下，マクロが続く（任意のファイルのデータをコピーする内容）

 Ｅｎｄ　Ｓｕｂ

 こんな感じでどうでしょうか。(ROUGE)ちょっと修正。2008/11/19 11:15
'----
Sub Robust_Cicada()
Dim ff, flg As Boolean
flg = False
With CreateObject("Scripting.FileSystemObject")
    For Each ff In .GetFolder(ThisWorkbook.Path).Files
        If InStr(1, ff.Name, ".xls") > 0 Then
            Select Case ff.Name
                Case "A.xls", "B.xls", "C.xls"
                Case Else
                    flg = True
                    Exit For
            End Select
        End If
    Next
End With
If flg Then
    Rem 続きのマクロを記載。
End If
End Sub

 どうもありがとうございます。
 それで，いろいろ勉強して，下記のようなコードを作りました。

 Sub Robust_Cicada()
 Dim ff, flg As Boolean
 flg = False
 With CreateObject("Scripting.FileSystemObject")
    For Each ff In .GetFolder(ThisWorkbook.Path).Files
        If InStr(1, ff.Name, ".xls") > 0 Then
            Select Case ff.Name
                Case "A.xls", "B.xls", "C.xls"
                Case Else
                    flg = True
                    Exit For
            End Select
        End If
    Next
 End With
 If flg Then

 Dim ws As Worksheet
 For Each ws In Sheets
     If ws.CodeName = "xyz" Then
         Application.DisplayAlerts = False
         ws.Delete
         Application.DisplayAlerts = True
         flg = True
         Exit For
     End If
 Next
 If Not flg Then Exit Sub

 マクロ実行

    End If
 End Sub

 これは，Ａ，Ｂ，Ｃ以外のファイルが見つかったら，Codename　XYZ　のシートを削除した後，
 マクロを実行し，その後，もう一度同じマクロを実行しようとしても，XYZのシートが削除
 されているから，同じマクロを実行できない，マクロは一度しか実行できないというものです。

 でも，つなげ方が悪いんだと思いますが，マクロが何度でも実行できてしまいます。

 これをうまくつなげて
 ①Ａ，Ｂ，Ｃ以外のファイルが見つかったら，マクロを実行。
 ②マクロは一度しか実行できず，再度マクロを実行しようとしても実行できない。
 というふうにするにはどうしたらよろしいでしょうか。
 素人ですみませんが，お願いします。

 （ミンミンゼミ）

 順番変えたらどうですか。
 一番最初にＡファイルのxyzシートが存在するかしないかチェックして、
 なかったらマクロ終了。
 xyzシートが存在してたら、Ａ，Ｂ，Ｃ以外のファイルがあるかをチェックして
 なかったらマクロ終了。
 それだけで済む話に思えますが。
 （通りすがり）

 まず、続きのマクロについて、SheetsのParent Objectが明示されていませんので、その作業対象はActiveなBookになります。
A、B、C以外のBookに対して作業を行う必要があるのであれば、フラグを使うのではなく、Selectステートメント内
に収めてしまえばよいと思います。
下記はその例（検証はまったくしていません）。
(ROUGE)
'----
Sub Robust_Cicada()
Dim ff, wb As Workbook, ws As Worksheet
With CreateObject("Scripting.FileSystemObject")
    For Each ff In .GetFolder(ThisWorkbook.Path).Files
        If InStr(1, ff.Name, ".xls") > 0 Then
            Select Case ff.Name
                Case "A.xls", "B.xls", "C.xls"
                Case Else
                    On Error Resume Next
                    Set wb = Workbooks(ff.Name)
                    If wb Is Nothing Then
                        Set wb = Workbooks.Open(ff.Path)
                    End If
                    For Each ws In wb.Sheets
                        If ws.CodeName = "xyz" Then
                            Application.DisplayAlerts = False
                            ws.Delete
                            Application.DisplayAlerts = True
                            Exit For
                        End If
                    Next
                    On Error GoTo 0
            End Select
        End If
    Next
End With
End Sub

 上のコードで試してみましたが，うまくいきませんでした。
 上のコードで下から２行目のEnd WithとEnd Subの間に実行するマクロを挿入するんですよね。
 たとえば，セルの色を変えるマクロを入れたんですが，
 Ａ，Ｂ，Ｃ以外の名前のファイルを貼り付けなくても，マクロを実行すると
 セルの色が変わってしまうんですが。
 もうちょっとでうまくいきそうなんですが，よろしくお願いします。

 （ミンミンゼミ）

 セルの色を変えるマクロというのは具体的にどのようなものでしょうか？
 上記例では、Selectステートメントに入れ込んでいますので、当初の仕様とは異なっております。
 (ROUGE)

 下記のような感じですけど。
 今回は試しにセルの色がオレンジになるようにしましたけど，本当は，
 Ａ，Ｂ，Ｃ以外の名前のファイルを貼り付けて，その内容をコピーするマクロ
 にする予定ですが。

 Sub Robust_Cicada()
 Dim ff, wb As Workbook, ws As Worksheet
 With CreateObject("Scripting.FileSystemObject")
    For Each ff In .GetFolder(ThisWorkbook.Path).Files
        If InStr(1, ff.Name, ".xls") > 0 Then
            Select Case ff.Name
                Case "A.xls", "B.xls", "C.xls"
                Case Else
                    On Error Resume Next
                    Set wb = Workbooks(ff.Name)
                    If wb Is Nothing Then
                        Set wb = Workbooks.Open(ff.Path)
                    End If
                    For Each ws In wb.Sheets
                        If ws.CodeName = "xyz" Then
                            Application.DisplayAlerts = False
                            ws.Delete
                            Application.DisplayAlerts = True
                            Exit For
                        End If
                    Next
                    On Error GoTo 0
            End Select
        End If
    Next
 End With

 Range("A1:A5").Select
    With Selection.Interior
        .ColorIndex = 46
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With

 End Sub

 （ミンミンゼミ）

 Parent Objectを明示することを考慮してください。
上記追加された部分では、セルしか指定されていません。
どのファイルのどのシートのセルが対象なのかがこれでは不明確です。
まずは仕様をじっくり考えられてはいかがでしょうか。
(ROUGE)

 ごぶさたしております。
 上の例，私の説明不足のように思います。
 続きのマクロは，Aのファイル内で作業を行います。

 よって，以下の感じにしたいのですが

 ①マクロはAファイル上に作り，Aファイルを開いて実行する。
 ②フォルダ内にA，B，C以外のファイルがない場合は，マクロを実行しても動かない。
 ③フォルダ内にA，B，C以外のファイル名のファイルを保存すると，マクロが実行される。
 ④続きのマクロはAファイル上で作業するもの。
 ⑤一度マクロを実行すると，再度実行できない。

 それで，たとえば，続きのマクロとして，Aファイルのシート２のセルがオレンジ色に
 なるように

 ThisWorkbook.Sheets("Sheet2").Select
 Range("A1:A5").Select
    With Selection.Interior
        .ColorIndex = 46
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With

 というのを入れてみたのですが，A，B，C以外のファイルを保存しなくても，マクロ
 が実行されてしまい，うまくいかないのですが。
 よろしくお願いします。

 （ミンミンゼミ）

 ＞A，B，C以外のファイルを保存しなくても，
 ＞マクロが実行されてしまい，うまくいかないのですが。
 と言う事ですが、
 「A,B,C以外のファイルが保存されている時に実行する」
 なんて記述がどこかにあるのですか？
 ご提示の7行の中には有りませんが。

 また、なさりたいことの確認ですが
 （テストとして）セル色をオレンジにするのは
 　１．A,B,C以外のファイルが有った場合全てのファイルのSheet2の範囲に実行
 　２．A,B,C以外のファイルが有った場合、それらのファイルのSheet2の範囲に実行
 どちらでしょう？

 (HANA)

 コードとやりたいことが乖離していますね。。。
 また、同じProcedureにしなくてはいけないのかも疑問です。
 追加されたコードはまったく別のこと、別フローにしても問題ないことのようです。
 「たとえば」ではなく、具体的に、簡潔に、必要なことを知らせてください。
 (ROUGE)

 どうもすみません。分かりやすく説明するのは難しいですね。
 具体的に説明させていただきます。

 同一フォルダ内に，Ａ，Ｂ，Ｃの３つのファイルがあります。
 それで，いろいろ教えてもらって，Ａファイルに下記のようなコードを作りました。

 Sub ()

 Dim ws As Worksheet, flg As Boolean
  For Each ws In Sheets
     If ws.CodeName = "xyz" Then
         Application.DisplayAlerts = False
         ws.Delete
         Application.DisplayAlerts = True
         flg = True
         Exit For
     End If
 Next
 If Not flg Then Exit Sub

 Dim aa, bb, astrLinks
 Dim fso As Object
 Set fso = CreateObject("Scripting.FileSystemObject")
 Application.ScreenUpdating = False
     For Each aa In fso.GetFolder(ThisWorkbook.Path & "\").Files
         If aa.Name <> ThisWorkbook.Name _
        And aa.Name <> "A.xls" And aa.Name <> "B.xls" And aa.Name <> "C.xls" Then

              Workbooks.Open Filename:=ThisWorkbook.Path & "\" & aa.Name, UpdateLinks:=0

              astrLinks = Workbooks(aa.Name).LinkSources(Type:=xlLinkTypeExcelLinks)

              If Not IsEmpty(astrLinks) Then
                 For Each bb In astrLinks
                     Workbooks(aa.Name).BreakLink Name:=bb, Type:=xlLinkTypeExcelLinks
                 Next
              End If

              Workbooks(aa.Name).Worksheets(1).Cells.Copy ThisWorkbook.Worksheets(1).Cells
              Workbooks(aa.Name).Close False
              Exit For
         End If
     Next
 Application.ScreenUpdating = True
 Set fso = Nothing

 End Sub

 これは，同一フォルダ内にＡ，Ｂ，Ｃ以外のファイル，たとえばＤファイルを保存
 したら，ＤファイルをＡファイルにコピーするものです。
 そして，一度マクロを実行すると，その後はマクロは実行できず，Ｄファイルを
 削除して，かわりにＥファイルを保存しても，マクロは実行されず，Ｅファイルが
 Ａファイルにコピーされることはありません。

 でも，このままでは，最初の段階で，Ｄファイルをフォルダ内に保存しなくても，
 マクロが実行されてしまいます。
 それで，一番始めに戻って，

 フォルダ内に，Ａ，Ｂ，Ｃ以外のファイルが見つからなかったらマクロを実行
 しない。
 Ａ，Ｂ，Ｃ以外のファイルが見つかったら，マクロを実行する。

 というコードをコードの先頭に付け加えて，Ａ，Ｂ，Ｃ以外のファイルが見つから
 なかったらマクロの実行をロックするようなことをしたいのですが。
 どうでしょうか。お願いします。

 （ミンミンゼミ）

 このマクロは、大きく分けて二つの部分から出来ていますが

 ＞このままでは，最初の段階で，Ｄファイルをフォルダ内に保存しなくても，
 ＞マクロが実行されてしまいます。
 これは、上側の部分（ws.Delete）が実行されてしまう
 と言う事ですか？

 でしたら、順番を考える必要が有ると思いますよ。
 ＞Ａ，Ｂ，Ｃ以外のファイルが見つかったら，マクロを実行する。
 これは、下側の部分で制御していますよね。
 ＞ws.Delete
 は、上側の部分で行われています。

 まず最初に
 　ws シートの有無を確認して　無い場合は　Exit Sub
 　有る場合は、次に進みます。
 次の処理は、
 　Ａ，Ｂ，Ｃ以外のファイルに対して、コピーを実行
 　＆　フラグを立てる
 最後に
 　フラグが立っていれば　wsシートを削除
 フラグが立って居なければ、コピーを実行していない
 （Ａ，Ｂ，Ｃ以外のファイルが無かった）のでそのまま終了

 と言った感じで組み替えなおして見るのはどうでしょう。

 ん？でも　よく見るとこれって上で
 （通りすがり）さんが書いて居られる事と同じですね。
 やってみて、上手く行かなかったのでしょうか？
 それとも、その直ぐ後にROUGEさんのコードが有るので
 そちらを先に試してみられたのでしょうか？

 (HANA)

 何度か読み返して、HANAさんが噛み砕いてくださって、ようやく朧気ながらやりたいことが見えてきました。
 フローとしては、このようなものでしょうか？
　
１．A.xlsが入っているフォルダを調査
２．A.xls、B.xls、C.xls以外のファイルがあるかどうか調査
３．２でファイルが見つかった場合、そのファイルにCodeNameがxyzのシートがあるかどうか調査
４．あればそのファイルの一番左のシートをA.xlsファイルの一番左のシートにコピペして保存せずに閉じる。
：
：
：
あれ？xyzシートの削除は必要なのですか？
　
やりたいことをフローにしてみると、整理できて良いかもしれませんね。
VBAコードから推測するのでは非効率です。
(ROUGE)

 ROUGEさん、「３」は違うくて
 【A.xls】ファイルにCodeNameがxyzのシートがあるかどうか調査
 では無いでしょうか。

 それにしても、上記コードだと実行する度に
 （D.xlsとE.xlsが有った場合）AブックのWorksheets(1)に
 重ねてコピーされてしまいますよね。
 （どちらか一方しか貼り付いていない結果）

 と言う事は
 「最初に当たったブックのみをコピー」
 なんですかね。
 それとも
 「基本的に４つのブックしか入らない」
 って事なんですかね。
 或いは
 「これはサンプルコードだから。実際は下に続けてコピーします！！」
 って事なんですかね。

 コピーしたらこのセルには必ずデータが入る
 ってセルが有るのなら
 「そのセルが空だったらコピー。データが有ったらコピーしない」
 程度でも良いのかもしれないですね。
 （一つだけ貼り付ける場合ですが・・・。）

 (HANA)

 分かりにくい説明におつきあいしていただき，ありがとうございます。
 順番に説明しますと以下のとおりになります。

 ※　同一フォルダ内に，A，B，C　のファイルがある。
 ※　マクロはAファイル上に作る。
 ※　Aファイル上に，CodeNameがxyzのシートを作る。

 １　フォルダ内に，A，B，C以外の名前のファイルがあるか調査する。
 ２　A，B，C以外の名前のファイルが見つからなかったらマクロを実行しない。

 ※　ここでフォルダ内に任意の名前のファイル（たとえばＤファイル）を貼り付ける。

 ３　フォルダ内を再度調査し，A，B，C以外の名前のファイル　（たとえばＤファイル）
 　　が見つかったら，マクロを実行する。

 マクロの内容は

 ４　Aファイル上のCodeNameがxyzのシートを削除する。
 ５　Ｄファイルのシート１を全選択して，Aファイルのシート１にコピーして
 　　貼り付ける。

 です。

 また，このマクロは１回しか実行できない。
 つまり，もう一度マクロを実行しようとしても，１，２，３までは実行されるのです
 が，４でxyzシートを削除しようとしても，既にxyzシートは削除されているので,
 ４から先に進まない。
 よって，何かの誤操作で，マクロ実行後，Ｄファイルを削除して，代わりにＥファイル 
 を貼り付けたとします。
 そして，また誤操作で，マクロを実行しても，Ｅファイルの内容がAファイルにコピー
 されることはなく，AファイルはＤファイルの内容がコピーされたままである。

 というようなことがしたいのですが。
 お分かりいただけたでしょうか。

 （ミンミンゼミ）

 1) まず Aファイルがそのフォルダに在るかどうかを確認ることからでは？
    ↑おっと、これはマクロを記述してあるファイルでしたね... 無視してください。
 2) なぜ CodeName なのでしょう？
 (seiya)

 こちらをご覧になったからじゃないですかね？
[[20080725130903]]『マクロボタンを２回目に押すと効かなくする』（サンハイツ）

 ミンミンゼミさんのコードを見た時に非常に↑が思い出されましたが
 ここまで来ると、ほとんど同じなので当然でしたね。（笑）

 (HANA)

 なるほど...
 私自身も覚えておりませんでした...

 ということは、最初にAファイルに該当シートが在るかどうか参照して
 なければ、そこでおしまいにすればよいのでは？
 シートの確認はCodeNameでもSheetNameでも確認して、在ればマクロの最後に
 削除するだけですから、どちらでもよさそうな気がしますが？
 (seiya)

 ようやく全貌が見えましたねｗ
(ROUGE)
'----
Sub Robust_Cicada()
Dim ff, wb As Workbook, ws As Worksheet, flg As Boolean
flg = False
For Each ws In ThisWorkbook.Sheets
    If ws.CodeName = "xyz" Then
        flg = True
        Exit For
    End If
Next
If Not flg Then Exit Sub
With CreateObject("Scripting.FileSystemObject")
    For Each ff In .GetFolder(ThisWorkbook.Path).Files
        If InStr(1, ff.Name, ".xls") > 0 Then
            Select Case ff.Name
                Case "A.xls", "B.xls", "C.xls"
                Case Else
                    On Error Resume Next
                    Set wb = Workbooks(ff.Name)
                    If wb Is Nothing Then
                        Set wb = Workbooks.Open(ff.Path)
                    End If
                    Exit For
                    On Error GoTo 0
            End Select
        End If
    Next
    If Not wb Is Nothing Then
        For Each ws In ThisWorkbook.Sheets
            If ws.CodeName = "xyz" Then
                Application.DisplayAlerts = False
                ws.Delete
                Application.DisplayAlerts = True
                Exit For
            End If
        Next
        ThisWorkbook.Sheets("Sheet1").Cells.Value = _
            wb.Sheets("Sheet1").Cells.Value
    End If
End With
End Sub

 どうもありがとうございます。
 それで，上のコードで試してみたのですが，私が説明したフローの５番目にあります

 「Ｄファイルのシート１を全選択して，Aファイルのシート１にコピーして貼り付ける。」

 というところがうまくできません。
 Ｄファイルが開いてしまって，変な動きになってしまいます。

 あとの部分はうまく動いたのですが。
 たとえば，
 A，B，C以外の名前のファイルが見つからなかったらマクロを実行しない。
 Ｄファイルが見つかって，マクロを実行すると，マクロは１回しか実行できない。
 というところはうまくできました。

 いかがでしょうか。よろしくお願いします。

 （ミンミンゼミ）

 貼り付けもうまくいっていないのでしょうか？
Ｄファイルは確かに開きっぱなしになっているとは思いますが。。。
上記修正してみました。
(ROUGE)
'----
Sub Robust_Cicada()
Dim ff, wb As Workbook, ws As Worksheet, flg As Boolean
flg = False
For Each ws In ThisWorkbook.Sheets
    If ws.CodeName = "xyz" Then
        flg = True
        Exit For
    End If
Next
If Not flg Then Exit Sub
With CreateObject("Scripting.FileSystemObject")
    For Each ff In .GetFolder(ThisWorkbook.Path).Files
        If InStr(1, ff.Name, ".xls") > 0 Then
            Select Case ff.Name
                Case "A.xls", "B.xls", "C.xls"
                Case Else
                    On Error Resume Next
                    Set wb = Workbooks(ff.Name)
                    flg = (wb Is Nothing)
                    If wb Is Nothing Then
                        Set wb = Workbooks.Open(ff.Path)
                    End If
                    Exit For
                    On Error GoTo 0
            End Select
        End If
    Next
    If Not wb Is Nothing Then
        For Each ws In ThisWorkbook.Sheets
            If ws.CodeName = "xyz" Then
                Application.DisplayAlerts = False
                ws.Delete
                Application.DisplayAlerts = True
                Exit For
            End If
        Next
        ThisWorkbook.Sheets("Sheet1").Cells.Value = _
            wb.Sheets("Sheet1").Cells.Value
        If flg Then wb.Close False
    End If
End With
End Sub

 どうもありがとうございます。
 Ｄファイルの貼り付け，うまくいきませんでした。
 それで，前に勉強したことを使って，下記のようにしたら，貼り付けがうまくいきました。
 また，Ｄファイルが見つからない場合はマクロが動かないし，Ｄファイルを貼り付け後もマクロが動きません。

 しかし，また問題があります。
 実はＤファイルにはリンクが付いているのですが，Ｄファイルにリンクがある場合，下記のコードを実行すると，
 「このブックには更新できないリンクが１つ以上含まれています。」
 と表示されてしまいます。
 このメッセージが表示されないで，自動でリンクを解除して貼り付くようにしたいのですが，どうすればいいでしょうか。
 一応，コードの終りの方に「BreakLink～」というのがあって，リンクを解除していると思うのですが，うまくいかないのです。

 （ミンミンゼミ）

 Sub Robust_Cicada()
Dim ff, wb As Workbook, ws As Worksheet, flg As Boolean
flg = False
For Each ws In ThisWorkbook.Sheets
    If ws.CodeName = "xyz" Then
        flg = True
        Exit For
    End If
Next
If Not flg Then Exit Sub
With CreateObject("Scripting.FileSystemObject")
    For Each ff In .GetFolder(ThisWorkbook.Path).Files
        If InStr(1, ff.Name, ".xls") > 0 Then
            Select Case ff.Name
                Case "A.xls", "B.xls", "C.xls"
                Case Else
                    On Error Resume Next
                    Set wb = Workbooks(ff.Name)
                    flg = (wb Is Nothing)
                    If wb Is Nothing Then
                        Set wb = Workbooks.Open(ff.Path)
                    End If
                    Exit For
                    On Error GoTo 0
            End Select
        End If
    Next
    If Not wb Is Nothing Then
        For Each ws In ThisWorkbook.Sheets
            If ws.CodeName = "xyz" Then
                Application.DisplayAlerts = False
                ws.Delete
                Application.DisplayAlerts = True
                Exit For
            End If

 Next
 If Not flg Then Exit Sub

 Dim aa, bb, astrLinks
 Dim fso As Object
 Set fso = CreateObject("Scripting.FileSystemObject")
 Application.ScreenUpdating = False
     For Each aa In fso.GetFolder(ThisWorkbook.Path & "\").Files
         If aa.Name <> ThisWorkbook.Name _
        And aa.Name <> "A.xls" And aa.Name <> "B.xls" And aa.Name <> "C.xls" Then

              Workbooks.Open Filename:=ThisWorkbook.Path & "\" & aa.Name, UpdateLinks:=0

              astrLinks = Workbooks(aa.Name).LinkSources(Type:=xlLinkTypeExcelLinks)

              If Not IsEmpty(astrLinks) Then
                 For Each bb In astrLinks
                     Workbooks(aa.Name).BreakLink Name:=bb, Type:=xlLinkTypeExcelLinks
                 Next
              End If

              Workbooks(aa.Name).Worksheets(1).Cells.Copy ThisWorkbook.Worksheets(1).Cells
              Workbooks(aa.Name).Close False
              Exit For
         End If
     Next
 Application.ScreenUpdating = True
 Set fso = Nothing

 End If
 End With
 End Sub

 「動けば良い」ってなら特に言うことはありませんが
 そうでないなら、現在のコードを
 日本語におきかえてみてはどうでしょう。

 Dファイルを２回探しているように思いますが。

 リンク解除については、
 「値貼り付け」をすれば良さそうに思います。

 １．セルを選択してコピー
 ２．値貼り付け
 ３．Esc
 の手順を記録に取ると、参考になるコードが得られると思います。

 (HANA)

 どうもありがとうございます。
 なるほど，そうすると，上のROUGEさんの修正コードで，コピー貼り付けの部分を

 Workbooks(ff.Name).Worksheets(1).Cells.Copy ThisWorkbook.Worksheets(1).Cells

 とすると，Ｄファイルを１回探すだけで，うまく動きました。

 それで，あとはＤファイルをリンク解除したいのですが，お教えのとおりやってみて
 下のようなものを作ったのですが，うまくいきませんでした。
 Ｄファイルのリンクを解除した上で，コピー貼り付けするようにしたいのですが，
 いい方法がありますでしょうか。
 ご教示願います。
　
（ミンミンゼミ）

 Sub Robust_Cicada()
 Dim ff, wb As Workbook, ws As Worksheet, flg As Boolean
 flg = False
 For Each ws In ThisWorkbook.Sheets
    If ws.CodeName = "xyz" Then
        flg = True
        Exit For
    End If
 Next
 If Not flg Then Exit Sub
 With CreateObject("Scripting.FileSystemObject")
    For Each ff In .GetFolder(ThisWorkbook.Path).Files
        If InStr(1, ff.Name, ".xls") > 0 Then
            Select Case ff.Name
                Case "A.xls", "B.xls", "C.xls"
                Case Else
                    On Error Resume Next
                    Set wb = Workbooks(ff.Name)
                    flg = (wb Is Nothing)
                    If wb Is Nothing Then
                        Set wb = Workbooks.Open(ff.Path)
                    End If
                    Exit For
                    On Error GoTo 0
            End Select
        End If
    Next
    If Not wb Is Nothing Then
        For Each ws In ThisWorkbook.Sheets
            If ws.CodeName = "xyz" Then
                Application.DisplayAlerts = False
                ws.Delete
                Application.DisplayAlerts = True
                Exit For
            End If
        Next

        Workbooks(ff.Name).Worksheets(1).Cells.Select
        Selection.Copy
        Workbooks(ff.Name).Worksheets(1).Cells.Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False

        Workbooks(ff.Name).Worksheets(1).Cells.Copy ThisWorkbook.Worksheets(1).Cells

        If flg Then wb.Close False
    End If
 End With
 End Sub

 コードを動かせる環境を整えるのが大変なので
 動かさなくても分かるように
 何が起きたのか、起きたことを教えて下さい。

 ＞下のようなものを作ったのですが，うまくいきませんでした。
 どの様に上手く行かなかったのですか？

 エラーが出て止まったのなら
 　エラーメッセージと、どの行で止まったのか
 最後まで動いたが結果が希望と違うなら
 　どの様にしたい所が、どの様に成ったのか

 ちなみに、コードネームがxyzのシートを２回探しているように思いますが
 ２回目は必ず有るので（消せばよいだけなので）
 即刻消してしまいましょう。
 　　xyz.Delete

 それから、削除の処理は後処理なので
 一番最後に持ってきておくのがよいと思います。

 (HANA)

 どうもお世話になります。
 上記コードでマクロを実行すると
 「このブックには更新できないリンクが１つ以上含まれています」
 というメッセージが表示されます。

 そして，その下に「継続」と「リンクの編集」というボタンが表示されるので，
 「継続」を押すと，ＡファイルにＤファイルのデータがリンクが解除された状態で貼り付きます。

 上記コードのうち

 Workbooks(ff.Name).Worksheets(1).Cells.Select
        Selection.Copy
        Workbooks(ff.Name).Worksheets(1).Cells.Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Application.CutCopyMode = False

 の部分をなくしてマクロを実行すると，リンクが付いたままコピー貼り付けされる
 ので，このコードはリンクを解除するために合っていると思われます。

 ただ，「このブックには～」というメッセージが表示されないで，自動的にＤファイルのリンクを解除して
 コピー貼り付けされるようにしたいのですが，いかがでしょうか。

 （ミンミンゼミ）

 こんにちは。かみちゃん　です。

 横から失礼します。

 > 「このブックには～」というメッセージが表示されないで

 リンク更新をしないで開きたいということでしょうか？

 Set wb = Workbooks.Open(ff.Path)
 の部分を
 Set wb = Workbooks.Open(ff.Path, 0)
 とすると、リンク更新せずに開くことができます。
 （メッセージは表示されません）

 詳しくは、Open メソッドのヘルプ等で引数UpdateLinksをご確認ください。

 (かみちゃん)
 2009-03-23 22:04

 ありがとうございます。うまくできました。
 なるほど。分かりました。

 すみませんが、あともう１つお聞きしたいことがあります。
 上のコードを実行したとき、Ｄファイルが一瞬出現して、Ｄファイルのシートを全選択する
 画面が現れてから、Ａファイルのシート１にコピー貼り付けされます。

 このＤファイルが一瞬現れる現象をなくすことはできますでしょうか。
 Ｄファイルが表示されることなく、Ａファイルにコピー貼り付けされるようにしたいのですが。
 いかがでしょうか。

 （ミンミンゼミ）

 こんにちは。かみちゃん です。

 > Ｄファイルが一瞬現れる現象をなくすことはできますでしょうか

 勘違いしているかもしれませんが、以下のような感じではいかがでしょうか？

 Application.ScreenUpdating = False

 '～　処　理　～

 Application.ScreenUpdating = True

 (かみちゃん)
 2009-03-25 12:40

 うまくできました。
 私がイメージしていたものができました。
 みなさん、大変お世話になりました。
 本当にありがとうございました。

 （ミンミンゼミ）

コメント返信：

[ 一覧(最新更新順) ]

[[20081119075059]] 『ファイルを検索してマクロ実行』（ミンミンゼミ） ページの最後に飛ぶ

[[20081119075059]]　『ファイルを検索してマクロ実行』（ミンミンゼミ）　ページの最後に飛ぶ