VBAで位置調整を自動でしていきたいと考えています。
VBAで位置調整を自動でしていきたいと考えています。 調整前は、ホンシが上下でバラバラになっていますが、調整後は横一列にホンシが横一列に自動で位置が調整され、調整された分グレーで塗りつぶすようにプログラム作成したいと思います。 条件としては下記になります。 ホンシを横一列に自動調整 自動調整された分はグレーで表示 ホンシの数が合わないばあは一番多い品名の一つ下に配置しホンシの位置を調整。 イメージを添付しましたので、ご教授の程宜しくお願い致します。 自動調整の目的としては、ホンシを横一列に並べるのが目的となっています。 ※データが多かったので位置調整後の絵を添付しています。 添付のグレーの部分が自動超背で塗りつぶしている部分になります ホンシのグレーで塗りつぶしている部分は分かりやすくグレーで塗りつぶししている箇所になります。 データ量が多く添付図が見にくいと思いますが宜しくお願い致します。
Visual Basic | Excel・99閲覧・50
ベストアンサー
添付図結果参照下さい。このようなことで良いでしょうか。 一応、行方向は3000行目まで、列方向は「AAA列（703列）」まで対応するようにしております。 列方向は、10列単位で1単位として処理しています。 ALL列（1000列）からALN列（1002列）には、プログラム実行中のデータを 仮置きするエリアにしていますので書込みを行なわないようにして下さい。 この画面内の範囲では、瞬殺で対応できますが、行列方向をフルに使用した場合の処理時間は未定です。 プログラム内には、変数n0からn4まで使用しています。 プログラムは以下の通りです。 Sub Sheet5_ボタン3_Click() Application.ScreenUpdating = False Cells(1, 1002).Value = 5 For n5 = 1 To 1000 Range(Cells(1, 1000), Cells(100, 1001)).Value = "" If WorksheetFunction.CountA(Range(Cells(Cells(1, 1002).Value + 1, 1), Cells(Cells(1, 1002).Value + 1, 900))) = 0 Then Exit For Else For n0 = 1 To 1000 Step 10 If Cells(3, n0).Value = "" Then Exit For Else For n1 = Cells(1, 1002).Value + 2 To 3000 If Cells(n1, n0 + 1).Value = "" _ And Cells(n1, n0 + 3).Value = "" Then For n3 = 1 To 100 If Cells(n3, 1000).Value = "" Then Cells(n3, 1000).Value = n1 - 1 Cells(n3, 1001).Value = n0 Exit For End If Next Exit For ElseIf Cells(n1, n0 + 3).Value Like "*" & "ホンシ" = True Then For n3 = 1 To 100 If Cells(n3, 1000).Value = "" Then Cells(n3, 1000).Value = n1 - 1 Cells(n3, 1001).Value = n0 Exit For End If Next Exit For End If Next End If Next Cells(1, 1002).Value = WorksheetFunction.Max(Range(Cells(1, 1000), Cells(100, 1000))) For n4 = 1 To 100 If Cells(n4, 1000).Value = "" Then Exit For Else If Cells(n4, 1000).Value <> Cells(1, 1002).Value Then Range(Cells(Cells(n4, 1000).Value + 1, (n4 - 1) * 10 + 1), Cells(Cells(1, 1002).Value, (n4 - 1) * 10 + 1 + 8)).Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.149998474074526 .PatternTintAndShade = 0 End With End If End If Next Range(Cells(1, 1000), Cells(100, 1001)).Value = "" End If Next End Sub
追伸： また、AHP列（900列）までの間に覚え書きなどの記入を行なわないようにお願いします。 このエリアに必要のない文字があれば、繰り返しの中断をさせることができないため。
質問者からのお礼コメント
遅くなり申し訳ございません。 本日プログラムを実行してみました。 私のやりたいことができました。 お忙しい中プログラム作成頂きありがとうございました。 また機会がありましたら宜しくお願い致します。
お礼日時：1/18 22:49
