@frswataru (本石渉)posted at 2020-10-16

Excel VBA 別のブックのセルをコピー＆貼付け

Q&A

解決したいこと

Excel VBA 別のブックのセル("F_検索.xlsm")をコピー＆貼付け
画面がチカチカします。もっとカッコいいコードはありますか。

該当するソースコード

 If Range("B1") = "" Then
        Windows("F_検索.xlsm").Activate
        Range("F7").Select
        Selection.Copy
        Windows("A_Sheet.xlsm").Activate
        Range("B1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, transpose:=False
    End If

    If Range("B2") = "" Then
        Windows("F_検索.xlsm").Activate
        Range("F11").Select
        Selection.Copy
        Windows("A_Sheet.xlsm").Activate
        Range("B2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, transpose:=False
    End If

0 likes

2Answer

@ShortArrow posted at 2020-10-16

デバッグしてないので、動く保証はないですが、
基本的な流れはこんな感じです。

ActivateやSelectionを多用すると、画面が切り替わるため、
チカチカします。

PasteSpecial を使うとどうしても、ActivateやSelectionが必要です。
これは、Valueプロパティを利用することで回避できます。

Sub Main()

    Dim SearchBook As Workbook
    Dim SheetBook As WorkBook
    Set SearchBook = Workbooks("F_検索.xlsm")
    Set SheetBook = Workbooks("A_Sheet.xlsm")

    ProcessOn

    If "" = ThisWorkBook.ActiveSheet.Cells(1,2) Then
        SheetBook.ActiveSheet.Cells(1,2).Value= _
        SearchBook.ActiveSheet.Cells(7,6).Value
    End If

    If "" = ThisWorkBook.ActiveSheet.Cells(2,2) Then
        SheetBook.ActiveSheet.Cells(1,2).Value= _
        SearchBook.ActiveSheet.Cells(11,6).Value
    End If

    ProcessOff

End Sub

Sub ProcessOn()
    With Application
        .ScreenUpdating = False              '画面の描画更新を停止する
        .Calculation = xlCalculationManual   '自動計算をOFFにする
        .EnableEvents = False                'イベントの発生を無効にする
        .Cursor = xlWait                     'マウスポインタを砂時計にする
    End With
End Sub

Sub ProcessOff()
    With Application
        .Cursor = xlDefault                     'マウスポインタをデフォルトにする
        .EnableEvents = True                    'イベントの発生を有効にする
        .Calculation = xlCalculationAutomatic   '自動計算をONにする
        .ScreenUpdating = True                  '画面の描画更新を有効にする
    End With
End Sub

参考：

1Like

Comments

@ShortArrow
そういえば、`ActiveSheet`の部分を`Worksheets(1)`に変えたほうがよいかもしれません。
@frswataru
Questioner
カッコいい動きになりました
最高です

@takahasinaoki posted at 2020-10-17

参考までに

Sub Test()
    Dim SrcSheet As Worksheet 'コピー元
    Dim DstSheet As Worksheet 'コピー先
    
    'Sheet1 の部分は対象のワークシート名に変更してください
    Set SrcSheet = Workbooks("F_検索.xlsm").Worksheets("Sheet1")
    Set DstSheet = Workbooks("A_Sheet.xlsm").Worksheets("Sheet1")
    
    '値のみコピーする場合
    DstSheet.Range("B1").Value = SrcSheet.Range("F7").Value
    DstSheet.Range("B2").Value = SrcSheet.Range("F11").Value
     
    '参考までに複数セルの値をコピーする場合は以下のように記述できます
    DstSheet.Range("B1:B4").Value = SrcSheet.Range("F7:F11").Value
 
    'セルの書式もコピーする場合は以下のように記述できます
    Call SrcSheet.Range("F7:F11").Copy(DstSheet.Range("B1"))
    '以下と同じです（Callで書いた方が見やすいのでCallで記述するのは筆者の好みです）
    SrcSheet.Range("F7:F11").Copy DstSheet.Range("B1")
     
    '形式を選択して貼り付けに該当する時は以下の記述となります
    SrcSheet.Range("F7:F11").Copy
    Call DstSheet.Range("B1").PasteSpecial(Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False)
End Sub

0Like

Are you sure you want to delete the question?