[[20050105170449]]　『Sheetから別Sheetコピー時の画面の移動』（キリキ）　ページの最後に飛ぶ

『Sheetから別Sheetコピー時の画面の移動』（キリキ）

 皆様、明けましておめでとうございます。
 本年も昨年同様、よろしくお願いいたします。

 大変初歩的な質問かと思いますが、マクロで同一Book内のSheetの一部をコピーし
 別Sheetに貼り付けしたいのですが、画面が一瞬移動します。
 どうすれば、画面の移動をしないコピペが出来ますでしょうか？
 よろしくお願いいたしますm(_ _)m

 Dim myr As Long, count As Long, p As Long
 Dim wst As Worksheet, wsh As Worksheet
 Set wsh = Sheets("発注台帳")
 Set wst = Sheets("タグ作成")
 p = -1
     For myr = 3 To 79 Step 4
         wsh.Activate
         If Cells(myr, 109) = "○" Then
             count = count + 1
             Range(Cells(myr, 8), Cells(myr, 106)).Copy
             With wst
                 If count Mod 2 <> 0 Then
                     p = p + 1
                 End If
                 .Cells(p * 14 + 3, 103) = Cells(myr - 1, 1)
                 .Cells(p * 14 + 5, 103) = Cells(myr + 1, 1)
                 .Cells(p * 14 + 7, 103) = Cells(myr - 1, 2)
                 .Cells(p * 14 + 13, 152) = Cells(myr - 1, 4)
                 .Cells(p * 14 + 10, 109) = Cells(myr + 1, 13)
                 .Range("B9:CV9").Offset(p * 14, 102).PasteSpecial Paste:=xlPasteValues
             End With
             Application.CutCopyMode = False
         End If
     Next myr
 End Sub

 マクロの最初に
 Application.ScreenUpdating = False  を入れて、
 最後に
 Application.ScreenUpdating = True   を入れてください。
 このコードの間では、画面の書き換えはありません。
 (sato)

 根本的には
 >         wsh.Activate
があるからかと思います。多分。
訂正追記：
なくしても動くわね…上記発言取消。
 >                 .Range("B9:CV9").Offset(p * 14, 102).PasteSpecial Paste:=xlPasteValues
の部分でごちゃごちゃ動くのね。
（ご近所PG）

 今回のは Application.ScreenUpdating = False  を入れても画面がちらつくんですね。
 ご近所さんのおっしゃるように、PasteSpecial Paste:=xlPasteValuesが原因のようなので
 一度コピーして書式のクリアではダメでしょうかね・・・。

 Sub Test()
 Dim myr As Long, count As Long, p As Long
 Dim wst As Worksheet, wsh As Worksheet
 Set wsh = Sheets("発注台帳")
 Set wst = Sheets("タグ作成")
 p = -1
     For myr = 3 To 79 Step 4
         If Cells(myr, 109) = "○" Then
             count = count + 1
             With wst
                 If count Mod 2 <> 0 Then
                     p = p + 1
                 End If
                 .Cells(p * 14 + 3, 103) = Cells(myr - 1, 1)
                 .Cells(p * 14 + 5, 103) = Cells(myr + 1, 1)
                 .Cells(p * 14 + 7, 103) = Cells(myr - 1, 2)
                 .Cells(p * 14 + 13, 152) = Cells(myr - 1, 4)
                 .Cells(p * 14 + 10, 109) = Cells(myr + 1, 13)
                 Range(Cells(myr, 8), Cells(myr, 106)).Copy Destination:= _
                 .Range("B9:CV9").Offset(p * 14, 102)
                 .Range("B9:CV9").Offset(p * 14, 102).ClearFormats
             End With
             Application.CutCopyMode = False
         End If
     Next myr
 End Sub

 （川野鮎太郎）

 同じセル範囲の大きさのRangeオブジェクト同士なら値の引渡しが
楽にできるので下記のような方法は良く使います。
 Sub test()
     Dim Rng1 As Range
     Dim Rng2 As Range
         With Worksheets(1)
             Set Rng1 = .Range(.Cells(1, 1), .Cells(1, 10))
         End With
         With Worksheets(2)
             Set Rng2 = .Range(.Cells(1, 1), .Cells(1, 10))
         End With
     Rng2.Value = Rng1.Value
 End Sub
　
応用できると思うけど。
（みやほりん）

 satoさん、ご近所PGさん、川野鮎太郎さん、みやほりんさん、ありがとうございます。

 説明不足で申し訳ありません、、、
 >Range(Cells(myr, 8), Cells(myr, 106)).Copy
 の部分には VLOOKUP関数が入っておりまして、0or1を返すようになっております。
 それを別Sheetに作ってある条件付き書式の部分に値複写をし、セルの色を付をしたかったのです(^_^;)
 例のJANコード作成ましぃ～んの改良版です（知らないか･･･

 川野さんの案ですと条件付書式が消えてしまいます(T_T)
 satoさんのコードを追加したら解決しました(^^)
 みやほりんさん案も素敵ですね～　
ありがとうございました(^o^)
（キリキ）

コメント返信：

[ 一覧(最新更新順) ]

[[20050105170449]] 『Sheetから別Sheetコピー時の画面の移動』（キリキ） ページの最後に飛ぶ

[[20050105170449]]　『Sheetから別Sheetコピー時の画面の移動』（キリキ）　ページの最後に飛ぶ