VBAで行を分割し、隣の列にコピペしていく方法

質問

よろしくお願いします。
三列・数十万行のデータがあります。一列目は1~N(数千程度)の整数が繰り返し現れます。二・三列目は文字・数値です。全体の行数はNの整数倍になっています。以下のような感じです。
1 A 3
2 C 27
3 J 0.8
...
2048 L 11
1 K 77
2 B 0
...
2048 G 99
1 H 10.3
2 Q 62
...
2048 D 8
このデータを、N行毎に分割し、四列目以降に張り付けたいです。以下のように…。
1 A 3 1 K 77 1 H 10.3
2 C 27 2 B 0 2 Q 62
3 J 0.8 ... ...
...
2048 L 11 2048 G 99 2048 D 8
このような操作をVBAでできないでしょうか。
下記リンクなどを参照したのですが、VBAについて知識がないため、所望の機能を得られていません。
http://okwave.jp/qa/q6342761.html
教えて頂けないでしょうか。よろしくお願いします。

回答No.7

moon00

すみません、検証不足でした。
以下のコードで修正します。

Sub bunkatsu()
Dim n As Long
Dim msg As String
Dim i, j, k As Long

msg = "N値を半角で入力してください。"
n = InputBox(msg)

i = 0
k = 0
Do While Cells(n + 1, 1) <> ""
Range(Cells(n + 1, 1), Cells(2 * n, 3)).Copy Destination:=Range(Cells(1, 4 + i), Cells(n, 6 + k))
Range(Cells(n + 1, 1), Cells(2 * n, 3)).Delete Shift:=xlShiftUp
i = i + 3
k = k + 4
Loop

Range("A1").Select

End Sub

ただ、エラーメッセージから見ると、コピーしようとしている場所にはなんらかの値があるようです。
（スペースかもしれませんが）
そうなると、アラートを無視するようにした方がいいのでしょうか・・・

お礼

何度もご丁寧にありがとうございました。海外出張のためお礼の入力が出来ず、遅くなりまして申し訳ありません。

作成頂いたマクロを実行してみたところ、無事目当ての形式のデータが得られました。本当に助かりました。ありがとうございます。

本来ベストアンサーに選ぶべきところ、出張中にgoo側が回答を締め切ってしまったようで、選ぶ事が出来なくなっていました。
自動で締め切る事を知らなかった私の不手際です。お詫び申し上げます。恐縮ながら今後とも、よろしくお願い申し上げます。

回答No.6

eden3616

度々失礼します。
出力結果についてですが、A列の値でソートが必要となりますか？

　　1 A 3 1 K 77 1 H 10.3
　　2 C 27 2 B 0 2 Q 62
　　3 J 0.8 ... ...
　　...
　　2048 L 11 2048 G 99 2048 D 8

ソートする処理を加えたコードになります。

■VBAコード（No5にA列昇順ソートを追加した物）

Sub action()
Dim i As Long
Dim hit As Long
Dim max_item As Long
Dim prm As String
Dim bk_prm As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
max_item = Cells(Rows.Count, "A").End(xlUp).Row
Application.StatusBar = "処理中です。しばらくお待ちください。"
For i = max_item To 1 Step -1
　　If Cells(i, "A") <> "" Then
　　　　hit = WorksheetFunction.Match(Cells(i, "A"), Columns("A"), 0)
　　　　If hit <> i Then
　　　　　　Range(Cells(i, "A"), Cells(i, "C")).Cut
　　　　　　Cells(hit, 4).Insert Shift:=xlToRight
　　　　End If
　　End If
　　If bk_prm <> Int((max_item - i) * 10 / max_item) Then
　　　　bk_prm = Int((max_item - i) * 10 / max_item)
　　　　prm = prm & "■"
　　　　Application.StatusBar = prm & WorksheetFunction.Rept("□", 10 - bk_prm) & bk_prm & "0%完了"
　　End If
　　DoEvents
Next i
Application.StatusBar = "■■■■■■■■■■100%完了"
ActiveWorkbook.Save
Range(Cells(1, "A"), Cells(Cells(Rows.Count, "A").End(xlUp).Row, "A")).Select
If WorksheetFunction.CountIf(Selection, "") = 0 Then GoTo skp
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
skp:
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Columns( _
　　"A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
　　xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
　　.SetRange Cells
　　.Header = xlGuess
　　.MatchCase = False
　　.Orientation = xlTopToBottom
　　.SortMethod = xlPinYin
　　.Apply
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox max_item & "件、終了しました。"
Application.StatusBar = False
End Sub

お礼

何度もご丁寧にありがとうございました。海外出張のため、お礼が遅れ申し訳ありません。

作成頂いたマクロを実行してみたのですが、数日置いてもマクロが終了しませんでした(CPUが100%近く動いているので、動作しているとは思います)。また、"処理中です。しばらくお待ちください。"や"~%終了"などのメッセージは出てきませんでした。
手動で終了してデータを確認してみると、最終行からN行前の行に多数の数値が並んでいましたが、他の部分は変わっておらず、結果として目当ての形式にはなっていませんでした。
私の使い方が悪いのかと思い、マクロに若干の変更を加えるなど色々と試してみたのですが、うまくいきませんでした。
今回は、moon00様の方法でやってみようと思います。

せっかくお骨折り頂いたのにお礼も申し上げられず、すみませんでした。今後とも、よろしくお願い致します。

回答No.5

eden3616

度々失礼します。
No4のコードですが、捕捉及び修正になります。

「ブックの上書き保存処理」を処理途中に入れることで以下の2通りの場合により
問題となる可能性があるため補足致します。

■作業対象とするブックにコードを記述して、『action』を実行する場合

一旦下記のVBAコードを記述したうえで、xls又はxlsm（マクロ有効形式）で保存してください。

■別ブックにコードを記述し、作業対象とするブックを選択した状態で『action』を実行する場合

作業対象のブックのファイル形式は問いませんが、新規ブックではなく初めに1度保存してください。
（新規ブックの場合は、上書き保存時に自動保存されますが出力先が前回保存したフォルダ内のxlsmファイルとして保存されます）

新規ブックを作成し、下記のVBAコードを追加し作業対象のブックを選択した状態でAlt+F8より新規ブック内の『action』を実行してください。
（マクロを記述した新規ブックは保存する必要はありません）

■VBAコード（No4のコードを修正しました）

Sub action()
Dim i As Long
Dim hit As Long
Dim max_item As Long
Dim prm As String
Dim bk_prm As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
max_item = Cells(Rows.Count, "A").End(xlUp).Row
For i = max_item To 1 Step -1
　　If Cells(i, "A") <> "" Then
　　　　hit = WorksheetFunction.Match(Cells(i, "A"), Columns("A"), 0)
　　　　If hit <> i Then
　　　　　　Range(Cells(i, "A"), Cells(i, "C")).Cut
　　　　　　Cells(hit, 4).Insert Shift:=xlToRight
　　　　End If
　　End If
　　If bk_prm <> Int((max_item - i) * 10 / max_item) Then
　　　　bk_prm = Int((max_item - i) * 10 / max_item)
　　　　prm = prm & "■"
　　　　Application.StatusBar = prm & WorksheetFunction.Rept("□", 10 - bk_prm) & bk_prm & "0%完了"
　　End If
　　DoEvents
Next i
Application.StatusBar = "■■■■■■■■■■100%完了"
ActiveWorkbook.Save
Range(Cells(1, "A"), Cells(Cells(Rows.Count, "A").End(xlUp).Row, "A")).Select
If WorksheetFunction.CountIf(Selection, "") = 0 Then GoTo skp
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
skp:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "終了"
Application.StatusBar = False
End Sub

回答No.4

eden3616

>頂いたコードを実行してみましたが、残念な事にメモリ不足のエラーメッセージが表示されました。
>今回のデータは約16万8千行、3.1 MBのデータです。PCのメモリは16 GBあります。
>よろしければ回答を補足頂ければ大変幸いです。どうぞよろしくお願い致します。

申し訳ありません。

こちらでもダミーデータ16万8千行をランダム作成し、試したところ同様のエラーが発生しました。
処理の最後、不要行を削除する段階でエラーが発生しておりました。
セルデータの処理でゴミデータが蓄積されたことが原因かと思います。

ブックをいったん保存すればゴミデータが消える為、
不要行の削除前に「上書き保存」する処理を加えております。
作業前のデータをバックアップとってからテスト実行願います。

また進捗状況を10％単位でステータスバーに表示するようにしました。

■VBAコード

Sub action()
Dim i As Long
Dim hit As Long
Dim max_item As Long
Dim prm As String
Dim bk_prm As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

max_item = Cells(Rows.Count, "A").End(xlUp).Row
For i = max_item To 1 Step -1
　　If Cells(i, "A") <> "" Then
　　　　hit = WorksheetFunction.Match(Cells(i, "A"), Columns("A"), 0)
　　　　If hit <> i Then
　　　　　　Range(Cells(i, "A"), Cells(i, "C")).Cut
　　　　　　Cells(hit, 4).Insert Shift:=xlToRight
　　　　End If
　　End If
　　If bk_prm <> Int((max_item - i) * 10 / max_item) Then
　　　　bk_prm = Int((max_item - i) * 10 / max_item)
　　　　prm = prm & "■"
　　　　Application.StatusBar = prm & WorksheetFunction.Rept("□", 10 - bk_prm) & bk_prm & "0%完了"
　　End If
　　DoEvents
Next i
Application.StatusBar = "■■■■■■■■■■100%完了"
ThisWorkbook.Save
Range(Cells(1, "A"), Cells(Cells(Rows.Count, "A").End(xlUp).Row, "A")).Select
If WorksheetFunction.CountIf(Selection, "") = 0 Then Exit Sub
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "終了"
Application.StatusBar = False
End Sub

回答No.3

moon00

すでにいくつか回答ついてますが、作ってみたので。

Sub bunkatsu()
Dim n As Long
Dim msg As String
Dim i, j, k As Long

msg = "N値を半角で入力してください。"
n = InputBox(msg)

i = 0
Do While Cells(n + 1, 1) <> ""
Range(Cells(n + 1, 1), Cells(2 * n, 3)).Copy Destination:=Range(Cells(1, 4 + i), Cells(n, 6))
Range(Cells(n + 1, 1), Cells(2 * n, 3)).Delete Shift:=xlShiftUp
i = 3
Loop

End Sub

作業シート自体を編集するので、元のシートをコピーしてからお使いください。

補足

ご回答頂き、ありがとうございます。お返事遅れ申し訳ありません。
頂いたコードを実行させて頂きました。しかし、なぜか正しい結果が帰ってきませんでした。症状が説明し難く煩雑になってしまい恐縮ですが、下記ご説明致します。
N値を半角で入力し先へ進むと、「選択したセルの内容を置き換えますか？」というボックスが出ます。ここで「いいえ」を選ぶとエラーとなります。「はい」を選ぶとボックスは消えますが、すぐに同じ「選択したセルの内容を置き換えますか？」というボックスが出ます。「はい」を選択し続けると(恐らくデータ総行数÷N回選択したのだと思います)、ボックスは出なくなり終了したようでした。
ここで出力された結果を見ると(質問に書いたデータで説明します)、
1 A 3
2 C 27
3 J 0.8
...
2048 L 11
1 K 77
2 B 0
...
2048 G 99
1 H 10.3
2 Q 62
...
2048 D 8
というデータが、
1 A 3 1 K 1 H 10.3
2 C 27 2 B 2 Q 62
3 J 0.8 ...
...
2048 L 11 2048 G 2048 D 8
となっているのです。つまり、データ総行数÷NをMとおいて、
・上からN行目までのデータは正常に出てきます。
・N+1から2N行目までのデータは、元々A, B列にあったデータのみ、D, F列に出てきます。
・2N+1から(M-1)N行目までのデータは消えます。
・(M-1)N+1からMN行目(最終行)までのデータは、F, G, H列に出てきます。I列以降にはデータは出てきません。
私の操作が間違っているのかもしれませんが、よろしければ回答を補足頂ければ幸いです。どうぞよろしくお願い致します。

回答No.2

tom04

こんにちは！
一例です。

元データはSheet1の1行目からあり、Sheet2に表示させるとします。
Sheet3を作業用のSheetとして使用していますので、
Sheet3は使っていない状態にしておいてください。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, k As Long, lastRow As Long, cnt As Long, wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
.Rows(1).Insert
.Range("A1") = "ダミー"
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
cnt = cnt + 1
.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
Range(.Cells(2, "A"), .Cells(lastRow, "C")).SpecialCells(xlCellTypeVisible).Copy wS3.Range("B1")
For k = 1 To wS3.Cells(Rows.Count, "B").End(xlUp).Row
wS3.Cells(k, "B").Resize(, 3).Copy wS2.Cells(cnt, Columns.Count).End(xlToLeft).Offset(, 1)
Next k
wS3.Range("B:D").ClearContents
Next i
.Rows(1).Delete
wS2.Range("A:A").Delete
wS3.Cells.Clear
End With
Application.ScreenUpdating = True
wS2.Activate
MsgBox "処理完了"
End Sub 'この行まで

※　最初に書いたようにSheet1のデータはA1セルからあり、
C列までの3列に入っていて、空白セルはないという前提です。m(_ _)m

補足

早速のご回答を頂き、感謝申し上げます。お返事遅くなり申し訳ありません。
頂いたコードを実行したところ、エラーなく実行されましたが、奇妙な結果が帰ってきました。質問に書いたデータで表すと、
1 A 3
2 C 27
3 J 0.8
...
2048 L 11
1 K 77
2 B 0
...
2048 G 99
1 H 10.3
2 Q 62
...
2048 D 8
というデータが、3N列(ここでは2048x3=6144列)を使って
(1行目)1 A 3 2 C 27 3 J 0.8 ... 2048 L 11
(N行空白)
(N+1行目)1 K 77 2 B 0 ... 2048 G 99
(N行空白)
(2N+1行目)1 H 10.3 2 Q 62 ... 2048 D 8
と表示されてしまいます。
すみませんが、回答を補足頂ければ大変幸いです。どうぞよろしくお願い致します。

回答No.1

eden3616

こういう事かな？

Alt+F11でVBEを開き、挿入→標準モジュールを挿入してください。
標準モジュールに以下のコードを貼付てVBEを閉じてください。
Alt+F8または表示→マクロから「action」を選んで実行してください。

■VBAコード

Sub action()
Dim i As Long
Dim hit As Long
Application.ScreenUpdating = False
For i = Cells(Rows.Count, "A").End(xlUp).Row To 1 Step -1
　　If Cells(i, "A") <> "" Then
　　　　hit = WorksheetFunction.Match(Cells(i, "A"), Columns("A"), 0)
　　　　If hit <> i Then
　　　　　　Range(Cells(i, "A"), Cells(i, "C")).Cut
　　　　　　Cells(hit, 4).Insert Shift:=xlToRight
　　　　End If
　　End If
Next i
Range(Cells(1, "A"), Cells(Cells(Rows.Count, "A").End(xlUp).Row, "A")).Select
If WorksheetFunction.CountIf(Selection, "") = 0 Then Exit Sub
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Application.ScreenUpdating = True
End Sub

補足

早速のご回答を頂き、ありがとうございます。こんなに早く回答が頂けると思っておりませんでしたもので、お返事が遅くなり申し訳ありません。
頂いたコードを実行してみましたが、残念な事にメモリ不足のエラーメッセージが表示されました。今回のデータは約16万8千行、3.1 MBのデータです。PCのメモリは16 GBあります。
よろしければ回答を補足頂ければ大変幸いです。どうぞよろしくお願い致します。