Excelで、とある表を一定の数ごとに区切りたい

質問

とある集計を行い、それを箱詰めするために、一定の数ごとに区切るリストに
マクロを使用して、作成したいのですが、どうしたらいいでしょうか？
参考画像の、左の小さい表から、右の大きい表のようにしたいのです。
何か方法はありますでしょうか？

回答No.2

tom04 · ベストアンサー

こんばんは！
画像が小さくて詳細が確認できないのですが・・・
おそらくこういうコトであろうという憶測です。

↓の画像でB列数値の合計が108になるごとに区切りたい！という解釈です。

前提条件としてデータは2行目以降にあり、A列は商品ごとに並んでいるとします。
商品に関係なく、B列数値のみ上から合計して、
「108」になるようにまとめて「108」を超えたものは、
行を挿入し、「108」を超えた数値を差し引いて表示としています。
（最終行は108に満たないこともあります）

シートモジュールですので、
画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に↓のコードをコピー＆ペースト
→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, k As Long, lastRow As Long, myVal
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
k = Int(WorksheetFunction.Sum(Range("B:B")) / 108) * 2
For i = 2 To lastRow + k
myVal = myVal + Cells(i, "B")
If myVal >= 108 Then
If myVal = 108 Then
Rows(i + 1).Insert
Cells(i + 1, "B") = 108
myVal = 0
i = i + 1
Else
Rows(i + 1 & ":" & i + 2).Insert
With Cells(i + 1, "B")
.Value = 108
.Offset(1) = myVal - 108
.Offset(1, -1) = Cells(i, "A")
.Offset(-1) = .Offset(-1) - .Offset(1)
End With
myVal = 0
i = i + 1
End If
End If
Next i
End Sub 'この行まで

※　一旦マクロを実行すると元に戻せませんので、
別Sheetでマクロを試してみてください。m(_ _)m

お礼

本当にありがとうございました！
古い？バージョンのため、他の方が
お教えいただいたものが、うまく機能せず
こちらの方を使用させていただきました。
お忙しい中、ありがとうございました！

回答No.3

kagakusuki

質問者様の画像では、左の小さい表のデータが何列の何行目以下に並べられているのかという事や、左の小さい表が何というシート名のシート上にあるのかという事、右の大きい表が何というシート名のシート上のどの様なセル範囲に出力すれば良いのかという事、等々、不明な点が多々御座いますので、前提条件として、元データである左の小さい表の中で、「ABC-181」といったコード番号(?)はA列に、「55」等の数値はB列に入力されているものとします。
　又、左の小さい表そのものを作り変えてしまうのでは、元データが失われてしまう事になりますから、左の小さい表はそのまま残る様にしておき、、右の大きい表を別のシート上のA列～B列に新たに作表するものとします。
　又、左の小さい表において、実際に数値が入力されているのは何行目からであるのかという事に関しては、マクロの方で自動的に検出し、B列に数値が入力されていない行範囲は、「商品」とか「数量」といった項目名が入力されている欄と見做して、新たに作成される右の大きい表の上側の所に、そのままコピーされる様にものとします。

　その場合、まず、元データである左の小さい表が存在しているシートを開いている状態とした上で、下記のマクロを使ってみて下さい。(書式もコピーされる様になっております)

Sub Macro()

Static pieces As Long
Dim q0 As Double
Dim sn1, sn2, s1, s2, s3, pn As String
Dim q, r0, r1, r2, rt, p1, p2, p3 As Long
Dim d As Boolean
Dim f As Variant

sn1 = ActiveSheet.Name
sn2 = sn1 & "箱詰"

If Application.WorksheetFunction. _
Count(Columns("B:B")) = 0 Then GoTo Label9

s1 = ""
s2 = "1箱あたりの入数は以下の個数で宜しいですか？"
s3 = Chr(10) & Chr(10) _
& "　※入数を0とするか、或いは[キャンセル]ボタンを押しますと" _
& Chr(10) & Chr(10) & "処理を中断してマクロを終了します"
If pieces < 0 Then pieces = 0

Label1:
If pieces = 0 Then s2 = "1箱あたりの入数を入力して下さい"
q0 = Application.InputBox(Title:="入数の入力", _
Prompt:=s1 & s2 & s3, Default:=pieces, Type:=1)
s1 = ""
If q0 = 0 Then GoTo Label8
If q0 < 0 Or Int(q0) < q0 Then
pieces = 0
s1 = "入数として設定できるのは正の整数値だけです"
Else
pieces = q0
End If
If pieces = 0 Then GoTo Label1

rt = 0
Do
rt = rt + 1
Loop Until Range("B" & rt) <> "" And IsNumeric(Range("B" & rt))

If Evaluate("NOT(ISREF('" & sn2 & "'!A1))") Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = sn2
End If
Sheets(sn2).Select
Columns("A:B").Clear
Sheets(sn1).Range("A1:B" & rt).Copy
With Range("A1")
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
With Range("A" & rt & ":B" & rt)
.Borders(xlEdgeTop).LineStyle = .Borders(xlEdgeBottom).LineStyle
.Borders(xlEdgeTop).Color = .Borders(xlEdgeBottom).Color
.Borders(xlEdgeTop).TintAndShade = .Borders(xlEdgeBottom).TintAndShade
.Borders(xlEdgeTop).Weight = .Borders(xlEdgeBottom).Weight
End With
r1 = rt - 1: r2 = r1: p1 = 0: p2 = 0: d = False
GoSub Label2

Application.CutCopyMode = False
Range("A" & rt & ":B" & rt).Copy
Do
r2 = r2 + 1
If p2 < 1 Then GoSub Label2
If p1 >= pieces Then GoSub Label3
If p1 + p2 < pieces Then
p3 = p2
Else
p3 = pieces - p1
End If
p1 = p1 + p3
p2 = p2 - p3
If d = False Then
With Range("A" & r2)
.Value = pn
.Offset(0, 1).Value = p3
.PasteSpecial Paste:=xlPasteFormats
End With
End If
Loop Until d
GoSub Label3

Application.CutCopyMode = False
Sheets(sn1).Range("A" & 1 & ":B" & rt - 1).Copy
Range("A1").PasteSpecial Paste:=xlPasteFormats
Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

GoTo Label0
Label2:
With Sheets(sn1)
Do
r1 = r1 + 1
d = Application.WorksheetFunction. _
Count(.Range("B" & r1 & ":B" & Columns.Rows.Count)) = 0
Loop Until d Or (.Range("B" & r1) > 0 And IsNumeric(.Range("B" & r1)))
If d Then
pn = "": p2 = 0
Else
pn = .Range("A" & r1).Value
p2 = .Range("B" & r1).Value
End If
End With
Return

Label3:
With Range("A" & r2)
.Value = ""
.Offset(0, 1).Value = p1
.PasteSpecial Paste:=xlPasteFormats
End With
p1 = 0: r2 = r2 + 1
Return

Label8:
s1 = "入数が設定されていません。" & Chr(10)
q = MsgBox("処理の実行を中止してマクロを終了します。" _
& vbLf & "宜しいですか?" _
& vbLf & vbLf & "　[はい]:終了" _
& vbLf & "　[いいえ]:入数の指定のやり直し" _
, vbYesNo + vbDefaultButton2, "処理中止")
If q = vbNo Then GoTo Label1
GoTo Label0

Label9:
q = MsgBox("元データには数量が入力されていません。" _
& vbLf & "　処理の実行を中止してマクロを終了します。" _
, vbOKOnly, "データ無し")

Label0:

End Sub

回答No.1

nonamochi

こんばんは

VBAでプログラムを組む必要がありますね。
行を挿入する間隔が一定であれば（例えば3行おき）、全体のデータ行数を（例えば）3で割った回数だけループを回して、都度行を挿入していけばできそうですね。
以下は例です。
行の挿入は
Range("2:2").Insert

データ行数が少なければループを回さずに
Range("3:3,4:4,5:5,6:6").Insert Shift:=xlDown
と一気に挿入してしまってもいいです。

括弧内の文字列は、それぞれプログラムで作ります。