エクセルVBA シートのデータ結合について質問です。 （左側の画像・統合シート / 右側の画像・統合修正シート）
エクセルVBA シートのデータ結合について質問です。 （左側の画像・統合シート / 右側の画像・統合修正シート） 「統合」シートの A列にタイムスタンプ、B列に所属、C列に名前、D列に物品名、E列に個数、F列に価格の値が入っています。データの最大数は都度変わり、最下行は決まっていません。また、物品に対しての価格も一定ではなく、同じ物品でも価格が違う場合があります。 やりたいことは、名前を基準にしてデータの数を最大１０個にまとめたいのです。 例えば、統合シートのさんぷる１さんのデータは１６個ありますので、１０個に収めるため、いまあるデータを順に３個ずつまとめて「統合修正」シートに転記できたらと考えています。 （１６個のデータ→まとめた３×５行とそのまま１行） （１４個のデータ→まとめた３×４行とそのまま2行） ※同じ名前であれば、A列のタイムスタンプ、B列の所属は基本的に同じ値になっています。 ※物品名をまとめる際、物品名の後に括弧入りの個数を入れたいです。また、物品名の間にスラッシュを入れたいです。個数列は個数の合計、価格列はまとめた物品の価格の合計を入れたいです。 ※データ数が１０に満たない場合は、そのまま上に詰めます。 ※この処理を統合シートの最下段まで行いたいです。 このような処理はVBAで可能でしょうか。 これまで手作業で行ってきてとても時間がかかるので、VBAでどうにかなればと思いネットで検索していましたが、自分ではうまく組み立てられませんでした。 お詳しい方、どうかご教示ください。
Excel | Visual Basic・137閲覧・100
ベストアンサー
ID非公開さん
2022/1/17 11:24
コードが長いので再回答します。 これまでの返信内容 >さんぷる１さんのデータは１６個ありますので、１０個に収めるため、 >いまあるデータを順に３個ずつまとめて・・ 16個を10行以内にするなら2個ずつで8行でもいいと思うのですが、何故3個ずつにするのですか？ そこの規則がわかりません。 【質問者さんの返信】 説明不足で申し訳ございません。実は特に規則はなく、素人目にひとつの数で決めた方がよいのかなと思った次第です。１０行以内であれば２個ずつ８行でも大丈夫です。すみません。よろしくお願いいたします。 10行以内というのは変えられない条件ですか？ そうすると個数（行）がふえると１行4個や5個になると思いますが、それでいいという事でしょうか。 またなるべく行は少なくした方がいいのですか？ 先の例では2個ずつより3個ずつの方がいいかという事です。 【質問者さんの返信】 説明不足の件、重ねてお詫び申し上げます。１０行以内というのは、変えられない条件になります。 行に関しては、１０行にできるだけ近くなった方がありがたいです。（１行にまとまる個数ができるだけ少ない方がありがたいです） 例えば、データの数が１１の場合、２個まとめたもの ＋ そのまま９個 計１０個でも大丈夫です。 統合修正シートは先に1行目に項目名だけ入力しておいて下さい。 Sub test() Dim dic As Object Dim sh1 As Worksheet, sh2 As Worksheet Dim r As Long Dim dkey As Variant Dim buf As Variant Dim cnt As Integer Dim i As Integer, j As Integer Dim hin As String Dim gt1 As Long, gt2 As Long Dim tmp As Variant Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") Set sh1 = Sheets("統合") Set sh2 = Sheets("統合修正") With sh2 If .Range("A2").value <> "" Then .Range("A2:F" & .Cells(Rows.Count, 1).End(xlUp).row).ClearContents End If End With With sh1 For r = 2 To .Cells(Rows.Count, 1).End(xlUp).row dkey = .Cells(r, 1).value & "," & .Cells(r, 2).value & "," & .Cells(r, 3).value If dic.Exists(dkey) = False Then dic.add dkey, r Else dic.Item(dkey) = dic.Item(dkey) & "," & r End If Next r End With '統合修正へ出力 With sh2 r = 1 For Each dkey In dic.Keys buf = Split(dic.Item(dkey), ",") cnt = WorksheetFunction.RoundUp((UBound(buf) + 1) / 10, 0) j = 0 hin = "" gt1 = 0 gt2 = 0 For i = 0 To UBound(buf) j = j + 1 If j > cnt Then r = r + 1 tmp = Split(dkey, ",") .Cells(r, 1).value = tmp(0) .Cells(r, 2).value = tmp(1) .Cells(r, 3).value = tmp(2) .Cells(r, 4).value = hin .Cells(r, 5).value = gt1 .Cells(r, 6).value = gt2 hin = sh1.Cells(buf(i), 4).value gt1 = sh1.Cells(buf(i), 5).value gt2 = sh1.Cells(buf(i), 6).value j = 1 Else If hin = "" Then hin = sh1.Cells(buf(i), 4).value Else hin = hin & "/" & sh1.Cells(buf(i), 4).value End If gt1 = gt1 + sh1.Cells(buf(i), 5).value gt2 = gt2 + sh1.Cells(buf(i), 6).value End If Next i '最後の出力 r = r + 1 tmp = Split(dkey, ",") .Cells(r, 1).value = tmp(0) .Cells(r, 2).value = tmp(1) .Cells(r, 3).value = tmp(2) .Cells(r, 4).value = hin .Cells(r, 5).value = gt1 .Cells(r, 6).value = gt2 Next dkey .Columns("D").AutoFit End With Set dic = Nothing Application.ScreenUpdating = True End Sub
ID非公開さん
2022/1/17 12:15
この内容はマクロにするのはそんなに簡単な内容ではありませんでした。 わからない部分はきいて頂ければ説明しますので、やってみた結果だけは知らせて下さるようお願いします。
質問者からのお礼コメント
私のつたない文章での質問にも丁寧に対応してくださり、望んでいた結果を完璧に得ることができるコードまでご教示くださいました。勉強中の自分にとっては、今回の的確なご回答かつ迅速なご対応に感謝するとともに憧れにも似た気持ちを持ちました。いつか自分もこんな回答ができるように、これからも地道に勉強を続けていきたいと思います。ほんとうにありがとうございました。
お礼日時：1/17 18:31
