VBA 選択している範囲のコピー＆ペーストのコードで重複しているコードを短くしたい。

teratailで助けてもらいながらマクロを作成しているVBA超初心者です。（5日前に始めました）
自分でいろいろ調べながら「抽出」シートのデータを[予定表]シートに値のみコピーするコードを書いてみたのですが、同じようなコードが並んでしまいました。
重複したコードをまとめて、短くコーディングすることはできるでしょうか。
本当はwithを使って書こうとしたのですが、うまく機能しませんでした。

「ActiveSheet.Range("B2").Select」は、エラー回避のために記載しています。
できればもっとわかりやすく書きたいと思っています。

このマクロの呼び出し方

Call Datacopy を使って他のマクロから呼び出します。

ファイルの環境

シート３つ：[予定表][データ一覧][抽出]

教えてほしいこと

１．コードを短くすっきりさせたい。
２．「ActiveSheet.Range("B2").Select」以外の書き方があれば教えてほしい。

お力を貸していただければ幸いです。
よろしくお願いします。

Sub Datacopy()

    '予定表にコピーする

    '予定表シートをクリアする
    Sheets("予定表").Range("C4:J303").ClearContents
    
        '以下で抽出シートのデータを予定表に張り付ける
        Sheets("抽出").Select
        
            '名前を張り付ける
            ActiveSheet.Range("B2").Select
            ActiveSheet.Range(Selection, Selection.End(xlDown)).Copy
            Sheets("予定表").Range("C4").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        
            '1回目の実施日を張り付ける
            ActiveSheet.Range("L2").Select
            ActiveSheet.Range(Selection, Selection.End(xlDown)).Copy
            Sheets("予定表").Range("D4").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        
            '2回目の予定日を張り付ける
            ActiveSheet.Range("M2").Select
            ActiveSheet.Range(Selection, Selection.End(xlDown)).Copy
            Sheets("予定表").Range("J4").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        
            '項目①を張り付ける
            ActiveSheet.Range("K2").Select
            ActiveSheet.Range(Selection, Selection.End(xlDown)).Copy
            Sheets("予定表").Range("H4").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        
        
            '項目②を張り付ける
            ActiveSheet.Range("O2").Select
            ActiveSheet.Range(Selection, Selection.End(xlDown)).Copy
            Sheets("予定表").Range("I4").PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        

End Sub

1T2R3M4

2021/05/21 21:16

作業依頼は別のサイトでお願いします。

kotatsu2

2021/05/22 01:02

すみません。1T2R3M4さん作業依頼ではなく、どのようにすればシンプルにかけるのかを教えていただきたかったので、ここに書いたのですが、間違っていましたか？

行動規範の内容に同意します

回答2件

Selectionを使わない方法ですが、RangeをSelectしていますから、そのRangeをSelectionのところに当てはめればよいわけです。

ActiveSheet.Range("B2").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Copy

'↓

With ActiveSheet
.Range(.Range("B2"), .Range("B2").End(xlDown)).Copy
End With

'とか

With Sheets("抽出")
.Range(.Range("B2"), .Range("B2").End(xlDown)).Copy
End With

投稿2021/05/22 04:47

plomte

総合スコア46

kotatsu2

2021/05/22 08:33

plomteさん、ありがとうございます。 With ActiveSheet .Range(.Range("B2"), .Range("B2").End(xlDown)).Copy End With の書き方でうまくいきました。ありがとうございました。

行動規範の内容に同意します

ベストアンサー

重複したコードをまとめたいということなら、
共通部分を見極めて、そこを別関数に切り出すことを考えてみたらいいと思います。

VBA
1Function myCopyPaste(moto As Range, saki As Range)
2    
3    moto.Worksheet.Range(moto, moto.End(xlDown)).Copy
4    saki.PasteSpecial Paste:=xlPasteValues
5    Application.CutCopyMode = False
6
7End Function
8
9Sub sample()
10    Dim ws1 As Worksheet
11    Dim ws2 As Worksheet
12    
13    Set ws1 = Worksheets("抽出")
14    Set ws2 = Worksheets("予定表")
15    
16    myCopyPaste ws1.Range("B2"), ws2.Range("C4")
17    myCopyPaste ws1.Range("L2"), ws2.Range("D4")
18    myCopyPaste ws1.Range("M2"), ws2.Range("J4")
19    myCopyPaste ws1.Range("K2"), ws2.Range("H4")
20    myCopyPaste ws1.Range("O2"), ws2.Range("I4")
21
22End Sub
23