[[20201218162056]]　『マクロで指定した回数だけ別シートへコピー』（h,n）　ページの最後に飛ぶ

『マクロで指定した回数だけ別シートへコピー』（h,n）

いつも大変参考にさせて頂いております。

以下の通りコピー元の行を、指定した回数別シートへコピーするマクロを作成しました。
正常に動作はしておりますが、コピー元のデータが多く、マクロ完了までにかなりの時間を要しております。
もう少し時間短縮出来るようなコードが御座いましたら、参考したく
質問させて頂きます。

Dim g As Long
Dim y As Long
Dim b As Long
Dim t As Long
Dim u As Long

Sheets("作業場").Select　’コピー元のシート
t = Sheets("作業場").Cells(Rows.Count, 2).End(xlUp).Row

Application.ScreenUpdating = False

    For u = 2 To t　'コピー元の行1万行程あります　
’2行目から最終行まで1行づつ指定した回数だけシート３へコピー
’シート３へはおおよそ10万行以上のデータがコピーされます。

     y = Cells(u, 1).Value '指定した回数の取得

    For i = 1 To y

        g = Sheets("sheet3").Cells(Rows.Count, 1).End(xlUp).Row + 1

        Range(Cells(u, 1), Cells(u, 20)).Copy Sheets("Sheet3").Cells(g, 1)
    Next i
    cntRec = cntRec + 1
Application.StatusBar = "処理実行中．．．．(" & t & " 件中　現在 " & cntRec & "件)"

    Next u

Application.StatusBar = False
'MsgBox "処理終了しました。(処理件数=" & cntRec & "件)"
Application.ScreenUpdating = True

End Sub

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

 こんばんは　＾＾
コピーされていますけど、写し方を拝見するに、数式等では無いですよね
値だけで良いのであれば比較的簡単に。。。配列を使うのも一案かもですね。
コピー元のa列にコピー回数が入力されているのですね。←　あれ！間違ってます？
＾＾；
（隠居じーさん） 2020/12/18(金) 17:24

■１
VBAの世界では基本的にシートやセルなど（オブジェクトといいます）を明示すれば、いちいちアクティブにしたり選択したりする必要はありません。

■２
標準モジュールでシートの指定を省略するとActiveSheetを指定したとみなされるきまりです。
よって、複数のブックやセルをまたぐ処理を考えているなら「■１」と合わせて、きちんと対象のオブジェクトを明示したほうがよいとおもいます。

■３
踏まえて整理するとこんな感じですよね？

    Sub ななしのまくろ()
        Dim t As Long, u As Long, i As Long, cntRec As Long

        With Sheets("作業場")  'コピー元のシート
            t = .Cells(.Rows.Count, 2).End(xlUp).Row

            For u = 2 To t  'コピー元の行1万行程あります
                For i = 1 To .Cells(u, 1).Value
                    Intersect(.Rows(u), .Range("A:T")).Copy Sheets("sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
                Next i

                cntRec = cntRec + 1
                Application.StatusBar = "処理実行中．．．．(" & t & " 件中　現在 " & cntRec & "件)"
            Next u
        End With

        Application.StatusBar = False
    End Sub

画面更新の抑制もされてますし、現状の２重ループで１行ずつコピーするというアプローチだとこれ以上の手はないような気がします。

■４
こちらで同じ環境が用意できないので試していませんが、別案として貼り付け先をResizeしてみるのはどうでしょうか？

    Sub 別案()
        Dim dstRNG As Range
        Dim i As Long

        Set dstRNG = Sheets("sheet3").Cells(Rows.Count, 1).End(xlUp)

        With Sheets("作業場")
            For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
                If .Cells(i, "A").Value > 0 Then
                    Intersect(.Rows(i), .Range("A:T")).Copy dstRNG.Resize(.Cells(i, "A").Value)
                    Set dstRNG = dstRNG.Offset(.Cells(i, "A").Value)
                End If
            Next i
        End With
    End Sub

（もこな２） 2020/12/18(金) 18:07

お二方ありがとうございます。
隠居じーさん　a列にコピー回数が入力されています。
もこな２さん　コードの提供ありがとうございます。

独学で最近覚えたばかりで、大変参考になります。
私にはまだ高度すぎて、ご質問に対してお答えできませんが、
時間短縮出来る気がしてきました。
■３を試してみたいと思います、比較的わかりやすいコードでしたので。
このようなサイトがあり、いつも感謝しております、大変ありがとうございました。

（h,n） 2020/12/18(金) 18:40

もこな２さん

■３のコードですと、私の作成したコードと同じくらいの処理速度でした。
■４ですが、すごいです、びっくりするくらい早いです！
Resizeの勉強致します、大変ありがとうございました。

（h,n） 2020/12/18(金) 19:16

 既にご案内があったよぉですが、言い出しっぺの配列案など。。。
処理件数が大量になると、すこ～しは速いと思いますです。＾＾；
値貼付けモードです。。。m(_ _)m
Sub OneInstanceM()
    Dim i             As Long
    Dim j             As Long
    Dim y             As Long
    Dim x             As Long
    Dim mTx()         As Variant
    Dim tAr()         As Variant
    Dim iMax          As Long
    Dim r             As Range
    Dim t             As Double
    t = Timer
    With Worksheets("作業場")
        tAr = .Cells(1, 1).CurrentRegion.Value
        Set r = Intersect(.Range("A:A"), .UsedRange)
        Set r = r.Offset(1).Resize(r.Rows.Count - 1, 1)
        iMax = Application.Sum(r)
        Set r = Nothing
    End With
    ReDim mTx(1 To iMax, 1 To 20)
    y = 1
    For i = 2 To UBound(tAr, 1)
        For j = 1 To tAr(i, 1)
            For x = 1 To 20
                mTx(y, x) = tAr(i, x)
            Next x
            y = y + 1
        Next j
        If i Mod 12800 = 0 And i >= 12800 Then DoEvents
    Next
    With Worksheets("Sheet3")
        .UsedRange.Clear
        .Cells(2, 1).Resize(UBound(mTx, 1), UBound(mTx, 2)) = mTx
        .Activate
    End With
    Erase mTx, tAr
    MsgBox "終了　" & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
（隠居じーさん） 2020/12/18(金) 22:04

 If i Mod 12800 = 0 And i >= 12800 Then DoEvents

↑

 失敗、失敗。。。両方1280に修正を。。。(◎_◎;)。。お願い
いたします。やたら動かすととても重くなりそぉなので工夫した
つもりが。。。あはは。。。ぜんぜんDoEventsやらないで終了し
ていましたね。。。（＾◇＾；）。。(T_T)
m(__)mすみませんでした。
（隠居じーさん） 2020/12/18(金) 22:19

隠居じーさん
コード提供ありがとうございます。
こちらも私に複雑なコードですが、今後の参考にいたします。
色々な方法があるのですね、大変参考になります。
（h,n） 2020/12/21(月) 08:19

コメント返信：

[ 一覧(最新更新順) ]

[[20201218162056]] 『マクロで指定した回数だけ別シートへコピー』（h,n） ページの最後に飛ぶ

[[20201218162056]]　『マクロで指定した回数だけ別シートへコピー』（h,n）　ページの最後に飛ぶ