[[20130515142738]]　『塗りつぶしセルのデータを別ブックにコピーする』（YE）　ページの最後に飛ぶ

『塗りつぶしセルのデータを別ブックにコピーする』（YE）

Excel2010,Windows 7を使用しています。

B列にある塗りつぶしセルを検索し、見つかった塗りつぶしセルのあるA～E列のデータを順次
別のブックにコピーペーストしていきたいのですが、下記VBAを実行したところ、何のエラーも表示されず、
待ち状態（検索中？）のまま動かずブックも閉じれなくなりました。

強制終了してログオフできましたが、どこがおかしかったのでしょうか？
又、このような事態になった場合、どうすれば良いでしょうか？

VBA初心者の為、詳しく教えていただけるとありがたいです。

 Dim FoundCell As Range, FirstCell As Range

  Application.FindFormat.Clear                   '初期化
  Application.FindFormat.Interior.ColorIndex = 7 'セルの書式の検索条件は背景色7（ピンク）に設定
  　　　　'B6～B1001内でピンクの背景色のセルをFoundCellに格納
  Set FoundCell = Range("B6:B1001").Find(What:="*", SearchFormat:=True)   
　If FoundCell Is Nothing Then                   '見つからなければ
    MsgBox "見つかりませんでした"                '「見つかりませんでした」と表示
    Exit Sub                                     
  Else                                           'そうでなければ（見つかれば）

　Workbooks.Open Filename:="\\LANDISK\share\会社\データ\新規リスト一覧.xlsm" 　　　　　　　　　　　　　　　　　　　　　　　　　

  Set　FirstCell=FoundCell                      '見つかったセルはFirstCellに格納

　　　　　'見つかったセルのA～E列をシート1の最終セルの1つ下のセルへコピーする
　FoundCell.Resize(1, 5).Copy Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
　End If
　Do
　　　　　　　　　　　　　'次に探して見つかったセルをFoundCellに格納

    Set FoundCell = Range("B6:B1001").Find(What:="*", After:=FoundCell, SearchFormat:=True)      
    If FoundCell Is Nothing Then
      MsgBox "見つかりませんでした"
      Exit Do
    Else                                  
      FoundCell.Resize(1, 5).Copy Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)     
  End If
　　　'FoundCellのアドレスと最初に見つかったアドレスが同じになるまで繰り返す
Loop Until FoundCell.Address = FirstCell.Address 
End　Sub

 まず、検索しようとしているシートは、どのブックの、どのシート？
 また、結果を書き込もうとしているシートは、どのブックのどのシート？

 アップされたコードでは、

 ・まず、最初に、マクロ実行時のアクティブシートに対してFind。
 ・そのあと、新規リスト一覧.xlsm　を開くので、この時点でアクティブシートは　新規リスト一覧.xlsmで
 　たまたま、開いたときにアクティブなシートになる。
 ・で、このシートにたいして　Set FoundCell = Range("B6:B1001").Find(・・
 　つまり、最初にFindをかけたシートと、明らかに異なるブックの異なるシートに対してFindをかけているね。

 ここが、根本的におかしいね。新規リスト一覧.xlsm　って何？

 (ぶらっと)

 原因は既にぶらっとさんから説明があるので、修正版の提示だけ。
 (Mook)

 Sub Sample()
    Dim srcWS As Worksheet
    Set srcWS = ActiveSheet

    Dim FoundCell As Range, FirstCell As Range
    Application.FindFormat.Clear                   '初期化
    Application.FindFormat.Interior.ColorIndex = 7 'セルの書式の検索条件は背景色7（ピンク）に設定
            'B6～B1001内でピンクの背景色のセルをFoundCellに格納
    Set FoundCell = srcWS.Range("B6:B1001").Find(What:="*", SearchFormat:=True)
    If FoundCell Is Nothing Then                   '見つからなければ
        MsgBox "見つかりませんでした"                '「見つかりませんでした」と表示
        Exit Sub
    End If

    Dim dstWS As Worksheet
    Set dstWS = Workbooks.Open(Filename:="\\LANDISK\share\会社\データ\新規リスト一覧.xlsm").Worksheets("Sheet1")

    '見つかったセルのA～E列をシート1の最終セルの1つ下のセルへコピーする
    Set FirstCell = FoundCell                     '見つかったセルはFirstCellに格納
    Do
        FoundCell.Resize(1, 5).Copy dstWS.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Set FoundCell = srcWS.Range("B6:B1001").Find(What:="*", After:=FoundCell, SearchFormat:=True)
    Loop Until FoundCell.Address = FirstCell.Address
 End Sub

 Mookさんからコードがでているんだけど、書いたので。（ほとんど同じ）
 なお、Application.FindFormat.Clear                   '初期化
 これは、最初は不要かな？　それより、最後に、後始末としていれておいたほうがいいね。
 あと、細かいところだけど、仮に B6 がピンク色塗りセルの場合、現行コードでは、このB6 が一番最後に転記されてしまうので
 ちょっとだけ、チューニング。

 Sub Sample()
    Dim FoundCell As Range, FirstCell As Range
    Dim mySh As Worksheet
    Dim toSh As Worksheet
    Dim myR As Range

    Set mySh = ThisWorkbook.Sheets("Sheet1")    '検索対象シート
    Set myR = mySh.Range("B6:B1001")

    Application.FindFormat.Interior.ColorIndex = 7 'セルの書式の検索条件は背景色7（ピンク）に設定
    'B6～B1001内でピンクの背景色のセルをFoundCellに格納
    Set FoundCell = myR.Find(What:="*", After:=myR.Cells(myR.Count), SearchFormat:=True)

    If FoundCell Is Nothing Then                   '見つからなければ
        MsgBox "見つかりませんでした"                '「見つかりませんでした」と表示
    Else                                           'そうでなければ（見つかれば）

        Set toSh = Workbooks.Open("\\LANDISK\share\会社\データ\新規リスト一覧.xlsm").Sheets(1)
        Set FirstCell = FoundCell                     '見つかったセルはFirstCellに格納

        Do
            '見つかったセルのA～E列をシート1の最終セルの1つ下のセルへコピーする
            FoundCell.Resize(1, 5).Copy toSh.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

            '次に探して見つかったセルをFoundCellに格納

            Set FoundCell = myR.Find(What:="*", After:=FoundCell, SearchFormat:=True)
            'FoundCellのアドレスと最初に見つかったアドレスが同じになるまで繰り返す
        Loop Until FoundCell.Address = FirstCell.Address

    End If

    Application.FindFormat.Clear                   'リセット

 End Sub

 (ぶらっと)

ぶらっとさんいつも早速のお返事ありがとうございます！！

よくよく見なおしてみるとなるほど、どのブックのどのシートか
明示していませんでしたね！！

それでたまたまアクティブになったシートに検索をかけることになり、
見つからず...あのおそろしい事態に...

しかも今私がじっくり見返して返信を打ち込んでいる間にMookさんまで！！
さすが皆さんお早いです！！いつもわかりやすく教えていただいて本当に
ありがとうございます！！

　検索しようとしているシートは...\\LANDISK\share\会社\検索\検索一覧.xlsm
　結果を書き込もうとしているシートは...\\LANDISK\share\会社\データ\新規リスト一覧.xlsm　です。

今からもう一度皆さんにいただいたお返事を勉強させていただきます！！
ちなみに...またあの恐ろしい事態になった場合、やはり強制終了でよかったのでしょうか？　（YE)

コメント返信：

[ 一覧(最新更新順) ]

[[20130515142738]] 『塗りつぶしセルのデータを別ブックにコピーする』（YE） ページの最後に飛ぶ

[[20130515142738]]　『塗りつぶしセルのデータを別ブックにコピーする』（YE）　ページの最後に飛ぶ