Excel データの再配置

質問

Excelでデータを再配置するマクロの組み方を教えて下さい！

参考画像→ http://goo.gl/2nLWH

画像左側のように複数のデータセットが縦方向に配置されているシートで、左上が「セット○」セルから始まるデータセット単位で横方向に空白列を挟んで再配置したいと思っています。
画像はサンプルデータで、実際には行数は不定数、列数は4列のセットが複数個存在します。

宜しくお願いします。

回答No.4

cj_mover · ベストアンサー

＃２、＃３、ｃｊです。

> できました！今までのマクロはコードを見た時に大体どのように実行されているのかなとわかったのですが、貴方様のコードはマクロ初心者の小生にはチンプンカンプンです(笑)流石です！
馬鹿にしてます？（笑）
内容的には、マクロの記録をアレンジしたような、
VBAというよりは、とてもEXCEL一般機能寄りの処理をしています。
　Set rTgt = .Range("A:A").SpecialCells(Type:=xlCellTypeConstants)
　（手作業なら、Ａ列を選択、F5キー、Alt+Sキー、Alt+Oキー、Enter）
で、Ａ列にある定数セルを取得して
　rTgt.Areas(i).Resize(, 4)
　（手作業なら、Ctrl+Alt+Sキー　Shift+→キーを３回、の繰り返し）
で、それぞれのセルブロック（領域）を４列に拡張して
　.Copy Destination:=Sheets("Sheet2").Cells(i * 5 - 4)
指定のセルに貼り付ける、、、
という内容です。

＃３のコード、より堅実に書き直しました。

Sub Re8130368dd()
　　Dim rTgt As Range
　　Dim i As Long
　　Set rTgt = Sheets("Sheet1").Range("A:A").SpecialCells(Type:=xlCellTypeConstants)
　　If rTgt Is Nothing Then Exit Sub
　　For i = 1 To rTgt.Areas.Count
　　　　rTgt.Areas(i).Resize(, 4).Copy Destination:=Sheets("Sheet2").Cells(i * 5 - 4)
　　Next i
　　Set rTgt = Nothing
End Sub

> ちなみに列数を5列や6列にするにはどのように変数を与えてやればよいでしょうか？
６列の場合、を見てもらえれば、要領が分かると思います。

Sub Re8130368d6()
　　Dim rTgt As Range
　　Dim i As Long
　　Set rTgt = Sheets("Sheet1").Range("A:A").SpecialCells(Type:=xlCellTypeConstants)
　　If rTgt Is Nothing Then Exit Sub
　　For i = 1 To rTgt.Areas.Count
　　　　rTgt.Areas(i).Resize(, 6).Copy Destination:=Sheets("Sheet2").Cells(i * 7 - 6)
　　Next i
　　Set rTgt = Nothing
End Sub

列数に依存しない書き方もありますが、今回の課題には必要なさそうなので、
また別の機会にでも、検討してみてください。

お礼

＞馬鹿にしてます？（笑）
とんでもございません！尊敬しております！！

この度は大変お世話になりました(^^ゞ

回答No.3

cj_mover

＃１です。
Sheet1からSheet2 にコピーするのでしたか？
では、

Sub Re8130368d()
　　Dim rTgt As Range
　　Dim i As Long
　　Set rTgt = Range("A:A").SpecialCells(Type:=xlCellTypeConstants)
　　For i = 1 To rTgt.Areas.Count
　　　　rTgt.Areas(i).Resize(, 4).Copy Destination:=Sheets("Sheet2").Cells(i * 5 - 4)
　　Next i
　　Set rTgt = Nothing
End Sub

補足

ご回答ありがとうございます！

できました！今までのマクロはコードを見た時に大体どのように実行されているのかなとわかったのですが、貴方様のコードはマクロ初心者の小生にはチンプンカンプンです(笑)流石です！

ちなみに列数を5列や6列にするにはどのように変数を与えてやればよいでしょうか？

回答No.2

cj_mover

別件の続きのようですね。
数式を使っていないですし、列数固定ということなので、
簡単な方法が却って効率的です。

Sub Re8130368c()
　　Dim rTgt As Range
　　Dim i As Long
　　Set rTgt = Range("A:A").SpecialCells(Type:=xlCellTypeConstants)
　　For i = 2 To rTgt.Areas.Count
　　　　rTgt.Areas(i).Resize(, 4).Cut Destination:=Cells(i * 5 - 4)
　　Next i
　　Set rTgt = Nothing
End Sub

回答No.1

KURUMITO

次のようなマクロでどうでしょう。

Sub 並び替え()
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
Dim i, n As Integer
i = 0
n = -4
Do
i = i + 1
If Left(WS1.Cells(i, "A"), 3) = "セット" Then
Setto1 = i
End If
Do
i = i + 1
If i > 500 Then Exit Do
Loop Until Left(WS1.Cells(i, "A"), 3) = "セット"
Setto2 = i - 1
Range(WS1.Cells(Setto1, "A"), Cells(Setto2, "D")).Copy
Do
n = n + 5
Loop Until WS2.Cells(1, n) = ""
ActiveSheet.Paste (WS2.Cells(1, n))
Application.CutCopyMode = False
i = i - 1
Loop Until i = 500
End Sub