『データの移動』（カフェ）

お世話になります。
下のような1行で横に長いデータが、1万行近くあります。これを、規則に沿って縦にしたいです。

1行目は項目です。Ａ列〜ＥＱ列は基本データです。
ＥＲ列〜ＭＡ列は、横長で3セルが ひとつづりになっています。
（ＥＲ〜ＥＴ，ＥＵ〜ＥＷ，ＥＸ〜ＥＺ・・・）データが入ってないセルも多々あります。

3セルの中で1セルでもデータが入っていれば、これを、ＥＲ列〜ＥＴ列に、縦に移動したいのです。
Ａ列〜ＥＱ列までは、同じデータをコピーします。

しかし、ＭＢ列〜ＭＨ列のどこかにデータがあるときだけは、
一番最後の行に、Ａ列〜ＥＱ列　プラス　ＭＢ列〜ＭＨ列　となるようにします。

ＶＢＡ初期の私には、大変難しく、時間がたつばかりです。
よろしくお願いいたします。



         A      B      C　　　D　　 E　 ・・・
2行目 　44B  点滴0　は-112A  床96　　　 ・・・ 

          ER　　 ES　　ET　　EU　  EV　　EW　 EX 　EY 　EZ 　FA　 FB　 FC ・・・
2行目  　 転  　 ◎　　30　　 転   　×  　       続    ▼    63     　○ ・・・

          MB　　 MC　　MD　　ME　 MF　　MG　 MH 　
2行目  　再採血　55B   keep   1             現行

　・　　　　　　　　　　・
　・　　　　　　　　　　・
　・　　　　　　　　　　・

 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - - - - - - - - - - - -    
↓　　↓　　↓  　　↓　　↓　　↓  　　↓　　↓　　↓




         A      B      C　　　D　　 E　 ・・・ ER　　 ES　　ET　　EU　  EV　EW ・・・・MB　　 MC　　MD　　ME　 MF　　MG　 MH 　
2行目 　44B  点滴0　は-112A  床96　　　 ・・・ 転  　 ◎　　30　
3行目 　44B  点滴0　は-112A  床96　　　 ・・・ 転   　×  　    
4行目　 44B  点滴0　は-112A  床96　　　 ・・・ 続     ▼    63 
5行目　 44B  点滴0　は-112A  床96　　　 ・・・    　　○　     
　・　　　　　　　　　　・
　・　　　　　　　　　　・
　・　　　　　　　　　　・
　　　　　　A      B      C　　　D　　 E　 ・・・ER　　 ES　　ET　　EU　  EV　　EW　 ・・・・MB　　 MC　　MD　　ME　 MF　　MG　 MH 　
            
最後の行　　44B  点滴0　は-112A  床96												　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　再採血　 55B   keep    1 　　　　　　　現行


















＜ 使用 Excel：Excel2007、使用 OS：Windows7 ＞
----
 コードを書きなぐっただけで検証していませんので不具合、あるいは勘違いあれば指摘願います。
 もう少し、すっきりさせることも、できるかもしれませんが、とりあえず。

 なお、オリジナルシートを組み変えて上書きするのではなく、別シートに展開。
 （以下コードでは Sheet1 ---> Sheet2）

 Sub Test1()
    Dim c As Range
    Dim w As Variant
    Dim mx As Long
    Dim x As Long
    Dim i As Long
    Dim j As Long
    Dim hd As Variant
    Dim n As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("Sheet1")   '元シート
        mx = .UsedRange.Rows.Count
        hd = .UsedRange.Rows(1).Value   'タイトル行
        
        ReDim w(1 To mx * 65, 1 To Columns("MH").Column)
    
        For i = 2 To mx
            For j = Columns("ER").Column To Columns("MA").Column Step 3
                If WorksheetFunction.CountA(.Cells(i, j).Resize(, 3)) > 0 Then
                    x = x + 1
                    For n = 1 To Columns("EQ").Column
                        w(x, n) = .Cells(i, n).Value
                    Next
                    w(x, Columns("ER").Column) = .Cells(i, j).Value
                    w(x, Columns("ES").Column) = .Cells(i, j + 1).Value
                    w(x, Columns("ET").Column) = .Cells(i, j + 2).Value
                End If
            Next
            
            If WorksheetFunction.CountA(.Range(.Cells(i, "MB"), .Cells(i, "MH"))) > 0 Then
                x = x + 1
                For n = 1 To Columns("EQ").Column
                    w(x, n) = .Cells(i, n).Value
                Next
                w(x, Columns("MB").Column) = .Rows(i).Range("MB1").Value
                w(x, Columns("MC").Column) = .Rows(i).Range("MC1").Value
                w(x, Columns("MD").Column) = .Rows(i).Range("MD1").Value
                w(x, Columns("ME").Column) = .Rows(i).Range("ME1").Value
                w(x, Columns("MF").Column) = .Rows(i).Range("MF1").Value
                w(x, Columns("MG").Column) = .Rows(i).Range("MG1").Value
                w(x, Columns("MH").Column) = .Rows(i).Range("MH1").Value
            End If
            
        Next
        
    End With
    
    With Sheets("Sheet2")
        .Cells.ClearContents
        .Range("A1").Resize(, UBound(hd, 2)).Value = hd
        .Range("A2").Resize(x, UBound(w, 2)).Value = w
        .Select
    End With
    
 End Sub

（β） 2016/01/04(月) 17:34
----
（β） さん、ありがとうございます。
さきほど、１回だけできました！　思い通りのデータ移動でした。
でも、2回目から、何度やっても強制終了になります。これで5回目です。
 
MB列からの
　　　　　　　　For n = 1 To Columns("EQ").Column
                    w(x, n) = .Cells(i, n).Value
                Next

ここで、問題が起こりましたので、強制終了します・・・のようなメッセージがでて、勝手にエクセルが閉じられます。


（カフェ） 2016/01/04(月) 18:53
----
 １回、２回、・・・・というのは、同じデータで繰り返し処理を行ったということですね。

 コード、アップ後、こそっと？　直しているところがあります。
 ReDim w(1 To mx * 65, 1 To Columns("MH").Column)
 ここですけど、この形で実行してもらっていますね。

 う〜ん・・・何でしょうかねぇ。
 そもそもが、１万行、データがきっしり入っていれば、６５万行のデータになるわけで
 これはこれで、ちょっと、空恐ろしい（？）ボリュームなんですが、メモリー関連でしょうか・・・

 エラー時の実際のデータは何行で、各行、３セルずつの組が、だいたいどれぐらいでしょうか？

（β） 2016/01/04(月) 19:04
----
（β） さん
サンプルで　16行ほどです。一行づつ、ステップインしているところですが、
先ほどと違って、すんなり移動できています。
会社のデータは、１万行、きっしり入っていることはありません。
頭を整理して、
                 

　　　　　　　　    w(x, Columns("ER").Column) = .Cells(i, j).Value
                    w(x, Columns("ES").Column) = .Cells(i, j + 1).Value
                    w(x, Columns("ET").Column) = .Cells(i, j + 2).Value

　　　　　　　　　　　　　　　この部分や、

                w(x, Columns("MB").Column) = .Rows(i).Range("MB1").Value
                w(x, Columns("MC").Column) = .Rows(i).Range("MC1").Value
                w(x, Columns("MD").Column) = .Rows(i).Range("MD1").Value
                w(x, Columns("ME").Column) = .Rows(i).Range("ME1").Value
                w(x, Columns("MF").Column) = .Rows(i).Range("MF1").Value
                w(x, Columns("MG").Column) = .Rows(i).Range("MG1").Value
                w(x, Columns("MH").Column) = .Rows(i).Range("MH1").Value

　　　　　　　　　　　　　　　この部分を勉強したいと思います。




（カフェ） 2016/01/04(月) 23:47
----
（β） さん 
昨日は、ありがとうございました！　サンプル1万行で試してみました。
問題なく、早くできました。　また、今のところ、何回試しても、止まることはありません。

 　ReDim w(1 To mx * 65, 1 To Columns("MH").Column)
ヘルプで見てみると、”動的配列変数の記憶域の容量を再度割り当てます。”と書いてありました。

このコードからいろいろと調べることができて、大変勉強になりました。

（β） さん 、本当にありがとうございました。また、よろしくお願いいたします。
（カフェ） 2016/01/05(火) 09:56