[[20240906065309]]　『名簿から一致でほかの列へコピペしたい』（朝男）　ページの最後に飛ぶ

『名簿から一致でほかの列へコピペしたい』（朝男）

一致した名簿をほかの列へコピペしたいと思っております。
一応機能はするのですが、動作がすごく重くて困っています。

動作を軽くしたいのですが、どなたかご教授いただけないでしょうか。

Sub Sec1()
Dim r As Integer
Dim myR As Integer
Application.Calculation = xlCalculationManual

Range("T61:AH90").ClearContents

For r = 100 To Cells(Rows.Count, 2).End(xlUp).Row

If Cells(r, 15).Value = Cells(63, 9).Value Then

myR = Cells(Rows.Count, 20).End(xlUp).Row
Range(Cells(r, 2), Cells(r, 16)).Copy
Cells(myR + 1, 20).Select
ActiveSheet.Paste

End If
Next

End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 一行ごとにコピーするなら、毎回myRを探さなくてもインクリメントしていくだけでよいのでは？
 Range(Cells(r, 2), Cells(r, 16)).Copy Cells(myR, "T")
 のように書いたほうがよいでしょう。（セル選択は無駄です）

 どのくらいのマッチ数なのか不明ですが、オートフィルタで絞り込んで
 一括してコピーという方法もあるでしょうね。

（xyz） 2024/09/06(金) 07:30:15

 もし必要なのは値だけなら、配列に書き込んでから一括してシートに書き込むと
 速度面では有利になります。それも検討されたらいかがですか？
（xyz） 2024/09/06(金) 07:58:46

■１
[[20240921053711]] でも同種のコメントをしましたが、適切なインデントをつけると全体の構造が把握しやすくなり、ご自身のデバッグ作業の効率アップに寄与するとおもいますので、こだわりがなければインデントをつけることを強くお勧めします。

踏まえて、私なりにインデントをつけると↓のようになります。

    Sub インデントをつけてみた()
        Dim r As Integer
        Dim myR As Integer
        Application.Calculation = xlCalculationManual

        Range("T61:AH90").ClearContents

        For r = 100 To Cells(Rows.Count, 2).End(xlUp).Row
            If Cells(r, 15).Value = Cells(63, 9).Value Then
                myR = Cells(Rows.Count, 20).End(xlUp).Row
                Range(Cells(r, 2), Cells(r, 16)).Copy
                Cells(myR + 1, 20).Select
                ActiveSheet.Paste
            End If
        Next r
    End Sub

■２
ExcelVBAの世界では基本的にシートやセル（オブジェクトと言います）をきちんと明示すれば、いちいちアクティブにしたり選択したりする必要はありません。
また、【標準モジュール】でシートの指定を省略した場合、ActiveSheetを指定したものとみなされるルールですから、可読性向上の観点からもきちんとオブジェクトを指定することをお勧めします。

■３
実行速度を気にされているようですが、それを気にするならば、一度で済むことを何度もしないということは鉄則だと思ってください。

したがって、配列案も出ているところですが、↓のように対象セル（範囲）をピックアップしておいて一括コピペすることも検討されるとよいと思いました。

    Sub コピペは1回()
        Dim bufRNG As Range
        Dim r As Integer

        With ActiveSheet
            .Range("T61:AH90").ClearContents

            For r = 100 To .Cells(.Rows.Count, "B").End(xlUp).Row
                If .Cells(r, "O").Value = .Range("I63").Value Then

                    If bufRNG Is Nothing Then
                        Set bufRNG = Cells(r, 2).Resize(, 15)
                    Else
                        Set bufRNG = Intersect(bufRNG, Cells(r, 2).Resize(, 15))
                    End If
                End If
            Next r

            If Not bufRNG Is Nothing Then
                '覚えたセル（範囲）があれば1度だけコピペ
                bufRNG.Copy .Cells(Rows.Count, 20).End(xlUp).Offset(1)
            End If
        End With
    End Sub

 ※説明のための提示であり完成品プレゼントの意図はありません。
　 採用される場合は【ステップ実行】により研究の上、理解できてから必要な部分のみご自身のコードに組み込んでください。

■４
また、飛び飛びになっている行範囲が多くてUnionが使いづらいといったことがあるならば、既に案内があるようにオートフィルタを使って絞り込むというのも有効だと思います。

いずれにせよ、しつこいようですが、実行速度を気にされるのであれば【1度で済むことを何度もやらない】というところを重点的に考えてみると良いと思います。

（もこな２） 2024/09/25(水) 19:53:51

コメント返信：

[ 一覧(最新更新順) ]

[[20240906065309]] 『名簿から一致でほかの列へコピペしたい』（朝男） ページの最後に飛ぶ

[[20240906065309]]　『名簿から一致でほかの列へコピペしたい』（朝男）　ページの最後に飛ぶ