[[20180717072711]]　『VBAにて。セルの値を連結。それを他のセルに代入＝x（のっす）　ページの最後に飛ぶ

『VBAにて。セルの値を連結。それを他のセルに代入。処理を早くしたい。』（のっす）

For j = 1 To 200

ワークシートオブジェクト2.Cells(k,j)=ワークシートオブジェクト1.Cells(i+1,j)&ワークシートオブジェクト1.Cells(i+2,j)&ワークシートオブジェクト1.Cells(i+3,j)&ワークシートオブジェクト1.Cells(i+4,j)
Next j

このような処理を、ワークシートオブジェクト2とワークシートオブジェクト1ともに、一定行ごとに何度も行うのですが、
処理を早くするためには、どのようなコードにすればよいでしょうか？

配列を使おうと思いましたが、正解にたどり着けません。
ご教示お願いいたします。

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

対象となる文字列が必ず固定長ならば、連結する文字列を固定長にしてMid関数で代入していけば、メモリの確保・解放動作がなくなって早くなりますが、可変ならばこの方法は使えません。

配列を使うと、セル値を配列に代入してから連結するという2度手間になるので、現状より遅くなるので、得策ではないでしょう。現状より早くするには、せいぜいシートオブジェクトをWithで使う程度であり、こんな方法では1msも変わらないのではないかと思います。現状のコードで十分だと思いますよ。

    Dim n As Long
    Dim cDim(3) As String

    With ワークシートオブジェクト1
        For j = 1 To 200
            For n = 0 To 3
                cDim(n) = .Cells(i + 1 + n, j).Text
            Next n
            ワークシートオブジェクト2.Cells(k, j) = Join(cDim, "")
        Next j
    End With
（???） 2018/07/17(火) 09:06

 ＞配列を使うと、セル値を配列に代入してから連結するという2度手間になるので、
 ＞現状より遅くなるので、得策ではないでしょう。

 私には理解不能。

 メモリー上で処理すれば速さは格段に違うと認識します。
 書き込みもまとめて一回にする。

 ＞一定行ごとに何度も行うのですが、 
 と言う割には、その全貌が提示されていないですね？

 先ず、インプットのデータ範囲、アウトプットのデータ範囲をそれぞれ算定してください。
 それらを配列に格納することから着手した方がいいと思います。

 ※ アウトプットの方は、入れ物だけ定義してもいいんですが、インプットと同じ方法で変数を作る方針とします。

（半平太） 2018/07/17(火) 10:09

全体の提示がないのでよくわかりませんけど、
k・・・Worksheet(2)の【1】行目で固定
i・・・Worksheet(1)の【1】行目で固定

と仮定した場合、こんな感じになるのかなぁ・・・
（Joinとか使ってもっとかっこよくできそうだけど、私のスキルでは無理でした・・・）

    Sub 配列使う()
        Const i As Long = 1
        Const k As Long = 1

        Dim a As Long, j As Long
        Dim Myarr(200) As Variant

        For j = 1 To 200
            With Worksheets(1).Cells(i + 1, j)
                Myarr(j - 1) = .Value & .Offset(0, 1).Value & .Offset(0, 2).Value
            End With
        Next j

        Worksheets(2).Cells(k, 1).Resize(, 200).Value = Myarr

    End Sub

    Sub 配列使わない()
        Const i As Long = 1
        Const k As Long = 1

        Dim a As Long, j As Long

        For j = 1 To 200
            With Worksheets(1).Cells(i + 1, j)
                Worksheets(2).Cells(k, j).Value = .Value & .Offset(0, 1).Value & .Offset(0, 2).Value
            End With
        Next j

    End Sub

データの量にもよるんでしょうが、テストしてみて率直な感想は200列くらいであれば悩んでる間に処理終わるっぽい
（もこな２） 2018/07/17(火) 12:39

配列を使うなら、
読み込みも配列に一気に読み込んだ方がより高速でしょう。

  Sub 配列使う()
    Const i As Long = 1
    Const k As Long = 1
    Dim a As Long, j As Long
    Dim SrcAry() '読み込み用配列
    Dim Myarr(200) As Variant '書き込み用配列

    With Worksheets(1)
        SrcAry = .Range(.Cells(i, 1), .Cells(i + 3, 200)).Value
    End With
    For j = 1 To UBound(SrcAry, 2)
            Myarr(j - 1) = SrcAry(1, j) & SrcAry(2, j) & SrcAry(3, j) & SrcAry(4, j)
    Next j
    Worksheets(2).Cells(k, 1).Resize(, UBound(Myarr)).Value = Myarr
  End Sub

200列ぐらいなら、体感できる差はでないと思いますが。
（hatena） 2018/07/17(火) 14:15

 ＞一定行ごとに何度も行うのですが、

 問題は「行数」だと思っています。

 本人が自己申告してくれないと分からないですけど、
 かなり大量だから「処理を早く」する方策が必要になった、
 と解釈したのですけども。

（半平太） 2018/07/17(火) 15:38

「行数」の自己申告がないので、とりあえず1000行として、
配列使う場合と、使わない場合の速度を計測してみました。

Worksheets(1)1000行200列を4行ずつ連結して、250行に纏めて、Worksheets(2) に出力する。

 Sub 配列使う1000()
    Dim Start As Single
    Dim i As Long
    Dim k As Long
    Dim a As Long, j As Long
    Dim SrcAry()    'ソース配列
    Dim Myarr(1 To 250, 1 To 200) As Variant    '出力配列

    Start = Timer
    Application.ScreenUpdating = False
    With Worksheets(1)
        SrcAry = .Range(.Cells(1, 1), .Cells(1000, 200)).Value
    End With

    For i = 1 To 1000 Step 4
        k = k + 1
        For j = 1 To UBound(SrcAry, 2)
            Myarr(k, j) = SrcAry(i, j) & SrcAry(i + 1, j) & SrcAry(i + 2, j) & SrcAry(i + 3, j)
        Next j
    Next i
    Worksheets(2).Cells(1, 1).Resize(UBound(Myarr), UBound(Myarr, 2)).Value = Myarr
    Application.ScreenUpdating = True

    Debug.Print "配列使用　:"; Timer - Start; "秒かかりました。"
 End Sub

 Sub 配列使わない1000()
    Dim Start As Single
    Dim i As Long
    Dim k As Long
    Dim a As Long, j As Long

    Start = Timer
    Application.ScreenUpdating = False
    With Worksheets(1)
        For i = 1 To 1000 Step 4
            k = k + 1
            For j = 1 To 200
                With .Cells(i, j)
                    Worksheets(2).Cells(k, j).Value = .Value & .Offset(1, j).Value & .Offset(2, j).Value & .Offset(3, j).Value
                End With
            Next j
        Next i
    End With
    Application.ScreenUpdating = True
    Debug.Print "配列不使用:";Timer - Start; "秒かかりました。"
 End Sub

3回ずつ実行した結果。

配列使用　: 0.3359375 秒かかりました。
配列使用　: 0.3203125 秒かかりました。
配列使用　: 0.3359375 秒かかりました。
配列不使用: 2.65625 秒かかりました。
配列不使用: 2.445313 秒かかりました。
配列不使用: 2.632813 秒かかりました。

テスト環境
Win10Home Excel2016 CPU core i7 RAM 16GB

配列使用の方が約8倍高速という結果でした。

（hatena） 2018/07/17(火) 20:26

 こんな感じでも・・・・・。
 直にセルのアドレスを指定して下さい。
 配列を使った方が速いけどね。
 （前に他サイト（閉鎖）で、藤代さんと言う方がテストしてたんだけど。）

 With Range("A1:D20")
    Range("F1").Resize(.Rows.Count).Value = _
              Application.Evaluate(.Columns(1).Address & " & " & .Columns(2).Address & " & " & .Columns(3).Address & " & " & .Columns(4).Address)
 End With

 ああ、２００列もあったのか・・・。
（BJ） 2018/07/18(水) 02:03

おはようございます。

多くの解答があって驚いています。
回答されたみなさん、ありがとうございます！
私の知識が薄いので、まだ1つの回答もしっかり理解できていない状況です。
が、必ず役立てたいと思います。

また相談させていただくこともあるかと思います。
そのときは、よろしくお願いいたします。
（のっす） 2018/07/18(水) 07:44

ここまでで一度も出てきていませんので補足すると、エクセル2013以降は状況次第でCellsアクセスが極端に遅くなります。

hatenaさんのコードで、白紙のブックでテストした場合
配列使用　: 0.09375 秒かかりました。
配列使用　: 9.765625E-02 秒かかりました。
配列使用　: 0.1015625 秒かかりました。
配列不使用: 2.136719 秒かかりました。
配列不使用: 7.609375 秒かかりました。
配列不使用: 8.585938 秒かかりました。
配列不使用: 27.77734 秒かかりました。
配列不使用: 40.53423 秒かかりました。

Windows10Pro Excel2016 CPU Xeon E5-1680v4 128GB

まっさらなブックで何故これほどのバラツキが発生するのかは知りませんが・・・。
2つ以上窓を開いていたり、数式の組み込まれたブックを開いていると処理時間が激増します。

当初の質問の趣旨とはズレますが、可能であれば一旦メモリに格納する方法を選択されると良いと思います。
（名無し） 2018/07/18(水) 14:16

はじめまして、、
皆様のコードのように綺麗ではないですが、データ5000件で試したところ一瞬だったので
参考までにどうぞ。

Sub 配列()

    Dim S1 As Worksheet, S2 As Worksheet, Lc As Long, i As Long
    Set S1 = ThisWorkbook.Sheets("Sheet1")
    Set S2 = ThisWorkbook.Sheets("Sheet2")

    Lc = S1.Range("A1").End(xlToRight).Column

    ReDim 読込配列(1 To 4, 1 To Lc)
    ReDim 書込配列(Lc)

    読込配列 = S1.Range(S1.Range("A1"), S1.Cells(4, Lc)).Value
    For i = 1 To Lc
        書込配列(i - 1) = 読込配列(1, i) & 読込配列(2, i) & 読込配列(3, i) & 読込配列(4, i)
    Next i

    S2.Range(S2.Range("A1"), S2.Cells(1, Lc)) = 書込配列
End Sub

（TAKA） 2018/07/18(水) 14:50

こんばんは。
TAKAさんのコードを見て、これや！と思いました。
早速自分のコードに組み込んでみます！
ありがとうございます！
（のっす） 2018/07/19(木) 00:04

 解決済みだけど、そういう結果でいいんだ・・・。
 ああ、シート指定して無いけど。

 With Range("A1", Range("A1").End(xlToRight))
     Range("A10").Resize(, .Columns.Count).Value = _
                 Application.Evaluate(.Rows(1).Address & " & " & .Rows(2).Address & " & " & .Rows(3).Address & " & " & .Rows(4).Address)
 End With
（BJ） 2018/07/19(木) 02:00

「これや！」って、
TAKAさんのコードは、（hatena） 2018/07/17(火) 14:15 の私のコードとほぼ同じですよね。
Sheet1 の 4行を連結して1行にして、Sheet2にコピーというを配列を使ってやっている。
違いは列数を固定の配列か、動的配列かだけですね。
質問の最初のコードが200列固定だからそれにあわせたんですけどね。

（hatena） 2018/07/21(土) 23:03

結局、全体の提示が無いので、本当は”何行”なのか、k,iがどのように変化していくのかの説明がないんですよね・・・
本題とは逸れますけど、こんなのでもありだったんでしょうか。
（Evaluateメソッド使えばもうちょっとマシになるのかもですが、ちょっとよくわからないです。。。）

    Sub Sample()

        Application.ScreenUpdating = False

        With Worksheets("Sheet2").Range("A1").Resize(5000, 200)
            .Cells(1).Formula = "=CONCATENATE(Sheet1!B1,Sheet1!C1,Sheet1!D1)"
            .Cells(1).AutoFill Destination:=.Rows(1)
            .Rows(1).AutoFill Destination:=.Cells
            .Value = .Value
        End With

        Application.ScreenUpdating = True

    End Sub
（もこな２） 2018/07/22(日) 01:23

結局、全体の提示が無いので、本当は”何行”なのか、k,iがどのように変化していくのかの説明がないんですよね・・・

そうなんですよね。

質問の最初のコードから最大限の推測を加えて、

A1 B1 C1 D1
A2 B2 C2 D2
A3 B3 C3 D3
A4 B4 C4 D4
A5 B5 C5 D5
A6 B6 C6 D6
A7 B7 C7 D7
A8 B8 C8 D8

のようなデータを、

A1A2A3A4 B1B2B3B4 C1C2C3C4 D1D2D3D4
A5A6A7A8 B5B6B7B8 C5C6C7C8 D5D6D7D8

のように4行毎に連結して1行に集約するというのがご希望かなと。
（質問者さん、ちがったら指摘してください。）

もこな２さんのコードだと、実行結果が下記になる。

B1C1D1 C1D1E1 D1E1F1 E1F1G1
B2C2D2 C2D2E2 D2E2F2 E2F2G2
B3C3D3 C3D3E3 D3E3F3 E3F3G3

で、

    .Cells(1).Formula = "=CONCATENATE(Sheet1!A1,Sheet1!A2,Sheet1!A3,Sheet1!A4)"

に書き換えてみると、

A1A2A3A4 B1B2B3B4 C1C2C3C4 D1D2D3D4
A2A3A4A5 B2B3B4B5 C2C3C4C5 D2D3D4D5

になった。想定とちょっと違う。
関数は苦手なのだが、いろいろ試行錯誤して、下記で想定どおりの結果になった。

    .Cells(1).Formula = "=OFFSET(Sheet1!A$1,ROW()*4-4,0)&OFFSET(Sheet1!A$1,ROW()*4-3,0)&OFFSET(Sheet1!A$1,ROW()*4-2,0)&OFFSET(Sheet1!A$1,ROW()*4-1,0)"

もっとスマートな式があるかもですが、これが私の限界です。
（hatena） 2018/07/22(日) 10:20

 kがどのように変化するかわからない...

     With ワークシートオブジェクト2
         For j = 1 To 200
             ワークシートオブジェクト1.Cells(k, j).Value = Join(Application.Index(.Cells(j, 1).Resize(, 200).Value, 1, 0), "")
         Next
     End With
（seiya） 2018/07/22(日) 11:20

実装できました。処理速度が以前より早くなっています。ありがとうございました！

今見返すと、私の質問が言葉足らず過ぎですね。
よく回答していただけたなと。。。感謝いたします。

TAKAさんのコードは、（hatena） 2018/07/17(火) 14:15 の私のコードとほぼ同じですよね。
今見ると、そうでしたね。わたしの、理解力不足でした。

hatenaさんの推測で間違いないです。

エクセルにて工程表を作成しており、シート1は、現在4300行です。これからも増えていきます。
iは、4300まで20行ごとに、kは、6行ごとに変化です。
（のっす） 2018/07/24(火) 06:43

（もこな２） 2018/07/22(日) 01:23　は、いろいろ勘違いしてたので全然ダメですけど、行の増加分が違うのであればそもそも数式作戦はよくないですね。

とりあえず、もともとはこんな感じだったってことですかね。

    Sub Sample()
        Dim ws1 As Worksheet: Set ws1 = Worksheets(1)
        Dim ws2 As Worksheet: Set ws2 = Worksheets(2)
        Dim j As Long
        Dim srcRow As Long, dstRow As Long

        With ws1
            dstRow = 1

            For srcRow = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row Step 20
                For j = 1 To 200
                    ws2.Cells(dstRow, j) = .Cells(srcRow + 1, j) & .Cells(srcRow + 2, j) & .Cells(srcRow + 3, j) & .Cells(srcRow + 4, j)
                Next j

                dstRow = dstRow + 6
            Next srcRow
        End With

    End Sub

しかし、出力セル範囲の行がとびとびであるなら2次元配列から一気に書き込むってできるんでしょうか？

配列使えば、少なくとも行ごとに200列分を一気に書き込むことはできるからそこがポイントってことなんでしょうか・・・
（もこな２） 2018/07/25(水) 06:41

おはようございます。

おおー！もともとは、そのような感じでした。

配列を使用して、一気に書き込みたいのですが、今のところ、
一気に書込みはできていない状況です。

それでも、だいぶ処理が早くなりました。

みなさん、ありがとうございました。
（のっす） 2018/07/26(木) 08:03

のっすさん、空欄の列があるなら、
最終列のとり方を

Range("A1").End(xlToLeft).Column

から

Cells(1, Columns.Count).Column

にかえてみてください。
（TAKA） 2018/07/26(木) 09:15

間違えました、

Cells(1, Columns.Count).End(xlToRight).Column

です
（TAKA） 2018/07/26(木) 09:16

間違えました、、
寝ぼけてるのか、、

Range("A1").End(xlToRight).Column

を

Cells(1, Columns.Count).End(xlToLeft).Column

にかえてみてください

（TAKA） 2018/07/26(木) 09:18

情報を小出しにするので、仕様が曖昧なままで回答者が推測を交えての回答を強いられている状況です。
いつまでたっても進展しません。

おおー！もともとは、そのような感じでした。

「そのような感じ」という曖昧な回答ではなく、明確にこうこうこういう仕様だと断言してください。

列数は200列固定なんですか。
出力先の１セルに連結するのは４行分ですか。
iは２０行ごと、Kは６行ごとということは、
２行目から５行目を連結　→　出力シートの1行目
22行目から25行目を連結　→　出力シートの7行目
42行目から45行目を連結　→　出力シートの13行目
・・・・・
ということで間違いないですか。

出力シートは空白ですか。それとも、すでにデータが入力されているのですか。
つまり、出力シートの２行目から６行目は空白なのか、何かデータがあるのか。

上記の点について明確な回答をお願いします。

実装できました。処理速度が以前より早くなっています。ありがとうございました！

その実装したコードを提示してください。
また、以前は、どのくらい処理時間だったのか、
実行後の処理時間はどのくらい短縮できたのか、も提示してください。
（hatena） 2018/07/26(木) 15:02

TAKAさん。
そういうことなんですねー。空白の列がない場合には、Range("A1").End(xlToRight).Column　が使えるんですね！

既にCells(1, Columns.Count).End(xlToLeft).Column を使用しておりました。

なぜRange("A1").End(xlToRight).Columnなのか、解っていなかったです。

これも、仕様が明確でないために起こったことですよね。
すみません。
（のっす） 2018/07/26(木) 22:40

natenaさん。　すみません。
ちょっと、さらしてみてもよいでしょうか？
汚すぎて、恥ずかしいのですが。。。
Sub MotoKouteihyouKaraSeisanKouteihyou改()

Dim ShMoto As Worksheet
Dim ShSei As Worksheet

 Set ShMoto = ThisWorkbook.Worksheets("元工程表")
 Set ShSei = ThisWorkbook.Worksheets("生産工程表")

ShSei.Application.ScreenUpdating = False

Dim i As Long
Dim u As Long
Dim o As Long
Dim e As Long
Dim uu As Long
uu = 16

'工程表の値消去
u = 16
ShSei.Select
Range(Cells(u, 1), Cells(Rows.Count, Columns.Count)).ClearContents

Dim 元工程表LastRow As Long

 元工程表LastRow = ShMoto.Cells(Rows.Count, mData.工程).End(xlUp).Row
Dim 生産工程表LastColumn As Long
 生産工程表LastColumn = ShSei.Cells(13, Columns.Count).End(xlToLeft).Column

'Bソー～検査　を転記　1回目
ShSei.Range(ShSei.Cells(uu, sData.工程), ShSei.Cells(uu + 5, sData.工程)).Value = ShSei.Range(ShSei.Cells(uu - 10, sData.工程), ShSei.Cells(uu - 5, sData.工程)).Value

For i = 29 To 元工程表LastRow Step 20
If ShMoto.Cells(i, mData.完成日) >= Date - 7 Then
'And IsDate(ShMoto.Cells(i + 8, mData.金具)) = False

ShSei.Cells(u, sData.発注先).Value = ShMoto.Cells(i + 2, mData.管理番号).Value '管理番号物件名を転記
ShSei.Cells(u, sData.口径).Value = ShMoto.Cells(i, mData.めっき).Value '口径
ShSei.Cells(u, sData.種別).Value = ShMoto.Cells(i, mData.X線).Value '形式
ShSei.Cells(u, sData.本数).Value = ShMoto.Cells(i, mData.施工).Value '本数
ShSei.Cells(u, sData.水協).Value = ShMoto.Cells(i + 3, mData.水協).Value '水協
ShSei.Cells(u, sData.立会).Value = ShMoto.Cells(i, mData.出荷方法).Value '立会
ShSei.Cells(u + 1, sData.種別).Value = ShMoto.Cells(i + 3, mData.めっき).Value 'めっき
ShSei.Cells(u + 1, sData.本数).Value = ShMoto.Cells(i + 3, mData.防食).Value '防食
ShSei.Cells(u + 1, sData.水協).Value = ShMoto.Cells(i + 3, mData.施工).Value '施工
ShSei.Cells(u + 1, sData.立会).Value = ShMoto.Cells(i + 3, mData.金具).Value '金具
ShSei.Cells(u, sData.納期).Value = ShMoto.Cells(i, mData.調整納期).Value '希望納期
ShSei.Cells(u + 2, sData.納期).Value = ShMoto.Cells(i + 5, mData.調整納期).Value '調整納期
ShSei.Cells(u + 3, sData.発注先).Value = ShMoto.Cells(i, mData.金具).Value '材料予定
ShSei.Cells(u, sData.担当).Value = ShMoto.Cells(i + 3, mData.依頼日).Value '依頼日を転記
ShSei.Cells(u + 3, sData.担当).Value = ShMoto.Cells(i, mData.依頼日).Value '営業所を転記
ShSei.Cells(u + 4, sData.担当).Value = ShMoto.Cells(i + 1, mData.依頼日).Value '営業担当を転記

 '切断～完成　を転記
'ShSei.Range(Cells(u - 1, sData.切断), Cells(u - 1, sData.完成)).Copy
'ShSei.Range(Cells(u + 4, sData.切断), Cells(u + 4, sData.完成)).PasteSpecial Paste:=xlPasteValues

  'Bソー～検査　を転記　2回目以降
'ShSei.Select
ShSei.Range(ShSei.Cells(uu + 6, sData.工程), ShSei.Cells(uu + 11, sData.工程)).Value = ShSei.Range(ShSei.Cells(uu, sData.工程), ShSei.Cells(uu + 5, sData.工程)).Value
   uu = uu + 6

    '材料　の入力
ShSei.Cells(u + 2, sData.発注先) = "材料"

'Dim oo As Long '元工程表から、チェックシート切断から完成までを転記

'oo = sData.切断

'For o = mData.めっき To mData.金具
'
'ShSei.Cells(u + 5, oo).Value = ShMoto.Cells(i + 8, o).Value
'oo = oo + 1
'Next o

'元工程表から工程線を転記配列使用
Dim Kouteisen As Variant

ShMoto.Select 'Bソー、Pコ、レーザの工程線転記
Kouteisen = ShMoto.Range(Cells(i, mData.工程 + 1), Cells(i + 2, mData.工程 + 500))
ShSei.Select
Range(Cells(u, sData.工程 + 1), Cells(u + 2, sData.工程 + 500)) = Kouteisen

'ShMoto.Select '水管の工程線転記
'Kouteisen = ShMoto.Range(Cells(i + 4, mData.備考 + 3), Cells(i + 4, mData.備考 + 200))
'ShSei.Select
'Range(Cells(u + 3, sData.工程 + 1), Cells(u + 3, sData.工程 + 200)) = Kouteisen

'ShMoto.Select '金具の工程線転記
'Kouteisen = ShMoto.Range(Cells(i + 3, mData.備考 + 3), Cells(i + 3, mData.備考 + 200))
'ShSei.Select
'Range(Cells(u + 4, sData.工程 + 1), Cells(u + 4, sData.工程 + 200)) = Kouteisen

ShMoto.Select '検査の工程線転記
Kouteisen = ShMoto.Range(Cells(i + 5, mData.工程 + 1), Cells(i + 5, mData.工程 + 500))
ShSei.Select
Range(Cells(u + 5, sData.工程 + 1), Cells(u + 5, sData.工程 + 500)) = Kouteisen

    ReDim 読込配列(1 To 10, 1 To 500)     '元工程表から工程線を転記
    ReDim 書込配列成形(500)
    ReDim 書込配列水管と金具(500)
    読込配列 = ShMoto.Range(ShMoto.Cells(i, mData.工程 + 1), ShMoto.Cells(i + 9, mData.工程 + 500))

    For e = 1 To 500      '水管と金具工程と、成形工程の転記 配列使用
    書込配列水管と金具(e - 1) = 読込配列(4, e) & 読込配列(5, e)
    書込配列成形(e - 1) = 読込配列(7, e) & 読込配列(8, e) & 読込配列(9, e) & 読込配列(10, e)
    Next e

    ShSei.Range(ShSei.Cells(u + 3, sData.工程 + 1), Cells(u + 3, sData.工程 + 500)) = 書込配列水管と金具               '水管と金具工程転記
    ShSei.Range(ShSei.Cells(u + 4, sData.工程 + 1), ShSei.Cells(u + 4, sData.工程 + 500)) = 書込配列成形              '成形工程転記
    ''ShMoto.Select

    ''For e = sData.工程 + 1 To 生産工程表LastColumn

    'ShSei.Cells(u, e).Value = ShMoto.Cells(i, e + 3).Value
    'ShSei.Cells(u + 1, e).Value = ShMoto.Cells(i + 1, e + 3)
    'ShSei.Cells(u + 2, e).Value = ShMoto.Cells(i + 2, e + 3)
    'ShSei.Cells(u + 3, e).Value = ShMoto.Cells(i + 4, e + 3)
    'ShSei.Cells(u + 4, e).Value = ShMoto.Cells(i + 3, e + 3)
    '↓1行は、改善前コード。
    'ShSei.Cells(u + 5, e).Value = ShMoto.Cells(i + 6, e + 3) & ShMoto.Cells(i + 7, e + 3) & ShMoto.Cells(i + 8, e + 3) & ShMoto.Cells(i + 9, e + 3).Value
    ''ShSei.Cells(u + 5, e).Value = ShMoto.Cells(i + 6, e + 4) & ShMoto.Cells(i + 7, e + 4) & ShMoto.Cells(i + 8, e + 4) & ShMoto.Cells(i + 9, e + 4).Value
    'ShSei.Cells(u + 6, e).Value = ShMoto.Cells(i + 5, e + 3)
    '
    ''Next e
u = u + 6
End If

Next i

ShSei.Rows.Hidden = False
ShSei.Columns.Hidden = False

ShSei.Select
ShSei.Range(Cells(8, sData.工程 + 1), Cells(8, Columns.Count).End(xlToLeft)).EntireColumn.ColumnWidth = 3

Dim y As Long '現在の日付から７日前以降の列を隠す
For y = sData.工程 + 1 To Cells(13, Columns.Count).End(xlToLeft).Column
If ShSei.Cells(13, y) = Date - 7 Then
ShSei.Range(Cells(13, sData.工程 + 1), Cells(13, y)).EntireColumn.Hidden = True

    Exit For
End If
Next y

End Sub

実装した箇所は、 ReDim 読込配列(1 To 10, 1 To 500) '元工程表から工程線を転記　のあたりです。

実装前は、しっかり計っていませんでしたが、30秒から1分。すごく長く感じました。
今は、5秒で処理完了します。

（のっす） 2018/07/26(木) 22:52

最初からなんとなく思ってましたけど、「Withステートメント」使ってないんですね。

とりあえず、配列の利用云々の前に、不必要なシート選択（シートの切り替え）はしないほうがいいとおもいます。
そのためにもWithステートメントの利用やオブジェクト型変数にシートを格納する方法を調べるところから手を付けたほうがよいかもしれません、

あと、ざっと見ですがコード提示するならするで回答者側で実験できるように、コード中に書かれていない情報
sData　や　 mData　が何であって、どこで定義してるのか　という情報も提示しないと
結局状況が掴めなくなる恐れがあるような気がします。
（もこな２） 2018/07/27(金) 04:26

もこな２さんもいってますが、Selectは不要です。遅くなるだけです。
例えば、

ShMoto.Select 'Bソー、Pコ、レーザの工程線転記
Kouteisen = ShMoto.Range(Cells(i, mData.工程 + 1), Cells(i + 2, mData.工程 + 500))

は、下記に書き換えましょう。

Kouteisen = ShMoto.Range(ShMoto.Cells(i, mData.工程 + 1), ShMoto.Cells(i + 2, mData.工程 + 500))

あるいは、
With ShMoto
Kouteisen = .Range(.Cells(i, mData.工程 + 1), .Cells(i + 2, mData.工程 + 500))
End With

連続したセル範囲を単純に転記する場合は、
変数に代入しなくても、直接、代入すればいいでしょう。

例えば、

は下記のように書き換えます。

ShSei.Range(ShSei.Cells(u, sData.工程 + 1), ShSei.Cells(u + 2, sData.工程 + 500)) = _
ShMoto.Range(ShMoto.Cells(i, mData.工程 + 1), ShMoto.Cells(i + 2, mData.工程 + 500))

単純な転記ではなく、修正を加えて転記する場合は、配列に格納してから、配列で修正してから、レンジに代入します。

とにかく、なるべくセルにアクセスする回数を減らすことを考えましょう。
（hatena） 2018/07/27(金) 20:48

ちょっと整理を試みたけど力尽きました・・・
そもそも論で、なんかの表にデータベースみたいなやつからデータをコピーしてるとおもいますが、データベース側が1行１レコードじゃないので問題を複雑にしてるっぽいです。
内容から察するに一人で使ってるものではなさそうなので、ちゃんと稟議にかけて身元のはっきりした会社に開発依頼をすることも検討されたほうがよいかも・・・

    Sub 整理してみた()
        Dim srcSH As Worksheet, dstSH As Worksheet
            Set srcSH = ThisWorkbook.Worksheets("元工程表")
            Set dstSH = ThisWorkbook.Worksheets("生産工程表")

        Dim Myarr(15) As Variant
        Dim RNGarr(15) As String
        Dim c As Long

        Dim i As Long, u As Long, o As Long, e As Long, uu As Long

        uu = 16
        u = 16

        With dstSH
            '工程表の値消去
            dstSH.Rows(u & ":" & dstSH.Rows.Count).ClearContents

            'Bソー～検査　を転記　1回目
            With .Cells(uu, sData.工程).Resize(6)
                .Value = .Offset(-10).Value
            End With
        End With

        With srcSH
            For i = 29 To .Cells(.Rows.Count, mData.工程).End(xlUp).Row Step 20
                Myarr(0) = .Cells(i + 2, mData.管理番号).Value  '管理番号物件名を転記
                Myarr(1) = .Cells(i, mData.めっき).Value        '口径
                Myarr(2) = .Cells(i, mData.X線).Value           '形式　【←種別では？】
                Myarr(3) = .Cells(i, mData.施工).Value          '本数
                Myarr(4) = .Cells(i + 3, mData.水協).Value      '水協
                Myarr(5) = .Cells(i, mData.出荷方法).Value      '立会
                Myarr(6) = .Cells(i + 3, mData.めっき).Value    'めっき
                Myarr(7) = .Cells(i + 3, mData.防食).Value      '防食
                Myarr(8) = .Cells(i + 3, mData.施工).Value      '施工
                Myarr(9) = .Cells(i + 3, mData.金具).Value      '金具
                Myarr(10) = .Cells(i, mData.調整納期).Value      '希望納期
                Myarr(11) = .Cells(i + 5, mData.調整納期).Value  '調整納期
                Myarr(12) = .Cells(i, mData.金具).Value          '材料予定
                Myarr(13) = .Cells(i + 3, mData.依頼日).Value    '依頼日を転記
                Myarr(14) = .Cells(i, mData.依頼日).Value        '営業所を転記
                Myarr(15) = .Cells(i + 1, mData.依頼日).Value    '営業担当を転記

                With dstSH
                    'ちゃんと並んでれば、そのままセル範囲として取得しちゃえばいいでしょうけど、どういう並びかわからないので念のため
                    RNGarr = Array(.Cells(16, sData.発注先).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(16, sData.口径).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(16, sData.種別).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(16, sData.本数).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(16, sData.水協).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(16, sData.立会).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(17, sData.種別).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(17, sData.本数).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(17, sData.水協).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(17, sData.立会).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(16, sData.納期).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(18, sData.納期).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(19, sData.発注先).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(16, sData.担当).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(19, sData.担当).Offset(u / 6 - 1).Address(False, False), _
                                   .Cells(20, sData.担当).Offset(u / 6 - 1).Address(False, False))

                    For c = 0 To 15
                        .Range(RNGarr(c)).Value = Myarr(c)
                    Next c
                End With

                u = u + 6
            Next i
        End With
    End Sub

（もこな２） 2018/07/28(土) 16:07

しまった。。。　こうですね

誤

        With dstSH
            '工程表の値消去
            dstSH.Rows(u & ":" & dstSH.Rows.Count).ClearContents

正

        With dstSH
            '工程表の値消去
            .Rows(u & ":" & .Rows.Count).ClearContents

（もこな２） 2018/07/28(土) 16:14

コメント返信：

[ 一覧(最新更新順) ]

[[20180717072711]] 『VBAにて。セルの値を連結。それを他のセルに代入＝x（のっす） ページの最後に飛ぶ

[[20180717072711]]　『VBAにて。セルの値を連結。それを他のセルに代入＝x（のっす）　ページの最後に飛ぶ