ID非公開
ID非公開さん
2022/1/19 18:49
1回答
【VBA教えて下さい】
【VBA教えて下さい】 写真の内容を実行出来るマクロを作成したいのですが、どのようなプログラムを作ればいいかご教授お願いします。 ◆やりたい事◆ ①左表に記入してある合計数量を別シートのフォームにデータ行を追加したい。 ②写真の様に左表の列、行の内容組み合わせで右表の別シートのフォームにデータを作成したい。 ◆希望条件◆ ①データ名称は左表の【列名称(自由名称)】＋【列の合計数を連番】＋【行名称】※行名称の前後はアンダーバー。 ②並び順は写真の通り、列・数・行の順で優先としたい。 左表の行項目を追加した場合は、右表の最後から追加。 ③左表の数を変更した時に右表にデータ行を挿入してデータを追加したい、並び順は各列項目の最後に持ってきたい。 例としてB2セルの数を2→3にした時、6,7行の間に行追加して“C06_AAA_”を作成したい。 ボタンを1つ設け、これらを実行。 数変更や項目追加して、再度ボタンを押した時は被り内容は無視し、新規追加分のみ追加としたい。 並び順や項目追加あたりのルールが固まっておらず変な事言ってるかもしれません。。 ややこしい内容になりますが、どなたか作成・回答よろしくお願いします。
Visual Basic | Excel・72閲覧
ベストアンサー
添付図のような結果です。よろしければ後の説明を見て下さい。 プログラムの条件として 1．頭にC、Sを付けるとの要望に対して： 2行目の（列）名称にて指示下さい。 2．プログラムが複雑となるため、AA列から実行中のデータの仮置きエリアを設定しています。 3．1行の店数を100列まで対応するようにしています。 但し、25列以上の場合は、AA列からの仮置きのエリアを100列以上の列に移動させて下さい。 4．A列の「AAA」「BBB」などの指定は、1,000まで対応するようにしています。 5．「別シート」に書込み可能な行数は、10,000行まで対応可能です。 6．データを新規に更新させる可能性を考慮して、リセットボタンを配置しています。 以上の設定でのプログラムは、以下の通りです。 Sub ボタン1_Click() Worksheets("別シート").Activate Dim n0 As Integer Dim n2 As Integer Dim n3 As Integer Dim n4 As Integer Dim r0 As Integer Dim myString As String Dim myN As Integer With Worksheets("Sheet1") For n0 = 3 To 1002 If .Cells(n0, 1).Value = "" Then Exit For Else For r0 = 1 To 100 If .Cells(1, 1 + r0).Value = "" Then Exit For Else .Cells(n0, 27 + (r0 - 1) * 2 + 2).Value = .Cells(n0, 1 + r0).Value - .Cells(n0, 27 + (r0 - 1) * 2 + 1).Value End If Next End If Next For r0 = 1 To 100 If .Cells(1, 1 + r0).Value = "" Then Exit For Else For n0 = 3 To 1002 If .Cells(n0, 1).Value = "" Then Exit For Else For n2 = .Cells(2, 27 + (r0 - 1) * 2 + 2).Value + 1 To .Cells(2, 27 + (r0 - 1) * 2 + 2).Value + .Cells(n0, 27 + (r0 - 1) * 2 + 2).Value If Len(n2) <= 9 Then myString = .Cells(2, 1 + r0).Value & "0" & n2 & "_" & .Cells(n0, 1).Value & "_" myN = Len(.Cells(2, 1 + r0).Value) For n3 = 2 To 10001 If Cells(n3, 6).Value = "" Then Cells(n3, 6).Value = myString .Cells(2, 27 + (r0 - 1) * 2 + 2).Value = .Cells(2, 27 + (r0 - 1) * 2 + 2).Value + 1 Exit For Else If Left(Cells(n3, 6).Value, myN) = .Cells(2, 1 + r0).Value Then For n4 = 1 To 10000 If Left(Cells(n3 + n4, 6).Value, myN) <> .Cells(2, 1 + r0).Value Then Range(Cells(n3 + n4, 6), Cells(n3 + n4, 8)).Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Cells(n3 + n4, 6).Value = myString .Cells(2, 27 + (r0 - 1) * 2 + 2).Value = .Cells(2, 27 + (r0 - 1) * 2 + 2).Value + 1 Exit For End If Next Exit For End If End If Next Else myString = .Cells(2, 1 + r0).Value & n2 & "_" & .Cells(n0, 1).Value & "_" myN = Len(.Cells(2, 1 + r0).Value) For n3 = 2 To 10001 If Left(Cells(n3, 6).Value, myN) = .Cells(2, 1 + r0).Value Then For n4 = 1 To 10000 If Left(Cells(n3 + n4, 6).Value, myN) <> .Cells(2, 1 + r0).Value Then Range(Cells(n3 + n4, 6), Cells(n3 + n4, 8)).Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Cells(n3 + n4, 6).Value = myString .Cells(2, 27 + (r0 - 1) * 2 + 2).Value = .Cells(2, 27 + (r0 - 1) * 2 + 2).Value + 1 Exit For End If Next Exit For End If Next End If Next End If Next End If Next For n0 = 3 To 1002 If .Cells(n0, 1).Value = "" Then Exit For Else For r0 = 1 To 100 If .Cells(1, 1 + r0).Value = "" Then Exit For Else .Cells(n0, 27 + (r0 - 1) * 2 + 1).Value = .Cells(n0, 1 + r0).Value End If Next End If Next End With Worksheets("Sheet1").Activate End Sub
リセットボタン： 間違えてボタンを押しても良いように警告のユーザーフォームを表示させるようにしています。 そのユーザーフォームで消去するかキャンセルするか判定させます。 リセットボタンのプログラム： Sub ボタン2_Click() UserForm1.Show End Sub ユーザーフォームの「キャンセル」ボタン： Private Sub CommandButton2_Click() UserForm1.Hide End Sub
質問者からのお礼コメント
理解に時間がかかってしまいましたが、理想の動きを再現できている事が確認でき、大変助かりました！ 複雑な内容だったと思いますがわざわざご対応下さりありがとうございました♪
お礼日時：1/26 18:50
