- 締切済み
Excel 複雑なセル埋めのVBA
エクセルで入力済みのデータをテーブル形式にするためにVBAを組んでいますが突き当たりました、お知恵を拝借させてください。現在成形出来ているのは以下の状態です。 A列 B列 C列 1行 AA 2 1 2行 3行 BB 3 2 4行 5行 6行 7行 8行 9行 CC 2 3 10行 11行 12行 13行 14行 これを以下のようにB列を埋めたいと考えています。A列を埋めるVBAは当方で分かります。 A列 B列 C列 1行 AA 1 1 2行 AA 2 3行 BB 1 2 4行 BB 2 5行 BB 3 6行 BB 1 7行 BB 2 8行 BB 3 9行 CC 1 3 10行 CC 2 11行 CC 1 12行 CC 2 13行 CC 1 14行 CC 2 B1に2が入っていてC1に1が入っているときはB1から下へ1，2の連番を1回入れます、B3に3と入っていてC3に2と入っているときはB3から下へ1,2,3の連番を2回繰り返します、同じようにB9以降も処理しています。連番のスタートは必ず1で、現在B列に入っている数字が連番の最後に当たる数値でC列が繰り返し回数という事です。上の例ではB列を書き直していますが、新たにD列にB列に入れたい連番の列を作る方法でもいいと思っています。 もし表が崩れていたら済みませんでした。恐れ入りますがポインタでも結構ですのでご教授下さい、よろしくお願いします。
- 0615yas
- お礼率83% (5/6)
- その他(業務ソフトウェア)
- 回答数3
- ありがとう数3
- みんなの回答 （3）
- 専門家の回答
みんなの回答
もっとよい方法があると思うのですが・・・ シート名は変更して下さい。一応D列に書き出しています。 勘違いなら御免なさい。 Sub SP_1() Dim Lrow As Long, myB As Long, myC As Long Dim f As Long, ff As Long, fff As Long Dim c As Long, buf() As Variant c = 0 With Worksheets("Sheet1") Lrow = .Range("A" & CStr(Rows.Count)).End(xlUp).Row For f = 1 To Lrow If .Range("B" & CStr(f)).Value <> "" Then myB = .Range("B" & CStr(f)).Value myC = .Range("C" & CStr(f)).Value For ff = 1 To myC For fff = 1 To myB c = c + 1 ReDim Preserve buf(1 To 1, 1 To c) buf(1, c) = fff Next Next End If Next .Range("D1").Resize(Lrow, 1).Value = _ WorksheetFunction.Transpose(buf) End With
お礼
御回答有り難うございました、ほぼ希望通りなのですがこのマクロを動かすと最後の9行目で止まってしまい14行目まで行きません。もしお心当たりがありましたらご教授いただけると幸いです。 同じ目的でも色々方法があるのが勉強になります。先にご回答頂いたマクロとの違いも自分なりにひもといてみようと思います。
- toshi_2000
- ベストアンサー率30% (306/1002)
マクロは、以下の通り I = 1 Do While I < 100 If Cells(I, 2) <> "" Then B = Cells(I, 2) C = Cells(I, 3) For J = 1 To C For K = 1 To B Cells(I + K - 1, 2) = K Next I = I + B Next End If Loop
お礼
有り難うございました、確認した所希望通りの動作です。ただ、自分の環境だけかもしれませんがマクロが終わった後にポインタが砂時計になり帰ってきません。これについては他のPCで調べるなどして何とか自分で解決を目指したいと思います。 このたびは大変助かりました、自分も頑張って回答者に回れるように精進したいと思います。
お礼
済みません、ご指摘の通りA列埋めずに動作確認してました。これで問題は解決しました、本当に有り難うございました。