エクセルのマクロでセルの内容によって行を挿入

エクセルのマクロでこんなことは出来るのでしょうか。

　　Ａ　　　　Ｂ
１　東京　　１
２　大阪　　３
３　札幌　　２
４　福岡　　１
５　横浜　　２

上記のような表をマクロの処理で下記のように書き換えることは出来るでしょうか。

　　Ａ　　　　Ｂ
１　東京　　１
２　大阪　　１
３　大阪　　１
４　大阪　　１
５　札幌　　１
６　札幌　　１
７　福岡　　１
８　横浜　　１
９　横浜　　１

Ｂ列に入ってる数字の分だけ行を作りたいのです。
（Ｂ列の数字マイナス1行を挿入する形になります）
書き換えがややこしければ、別の場所に作り直してもかまわないので
お願いします。

No.1 回答者： survey 回答日時： 2007/07/06 18:12

Sub Kakikae()

' 初期設定
Dim A() as String,B() as Integer,Counter as Integer, _
i as Integer,j as Integer,Gyou as Integer
Redim A(0),B(0)

' データの取得
Do
' B行が空の場合はループから出る
A(0)=Range("B2").Offset(Counter,0)
B(0)=Range("C2").Offset(Counter,0)
If A(0)="" Then
Exit Do
End If
' 配列の拡張
Counter=Counter+1
Redim Preserve A(Counter),B(Counter)
' データ格納
A(Counter)=A(0):B(Counter)=B(0)
DoEvents
Loop

' 書き込み
For i=1 to Counter
For j=1 to B(i)
' 行番号
Gyou=Gyou+1
Range("A1").Offset(Gyou,0)=Gyou
' A,B
Range("B1").Offset(Gyou,0)=A(i)
Range("C1").Offset(Gyou,0)=1
DoEvents
Next j
Next i
End Sub

この回答へのお礼

ありがとうございます。
御礼が遅くなって申し訳ありません。
やってみましたが、うまく動かず、私には難しすぎました。
勉強しなおしてきます。

お礼日時：2007/07/09 17:33

No.2 回答者： imogasi 回答日時： 2007/07/06 18:42

行挿入・削除は、そのロジックを良く考えて、作らないと、自分の実行いている行や、追加すべき行を混乱するものになりがちです。

下記は、現在データの下に増加させて、現在データはそのままにして、その点の判りにくさを避けています。
Sub test01()
d = Range("A65536").End(xlUp).Row
' MsgBox d
k = d + 1
For i = 1 To d
Cells(i, "C") = i
If Cells(i, "B") = 1 Then
Else
For j = 1 To Cells(i, "B") - 1
Cells(k, "A") = Cells(i, "A")
Cells(k, "B") = 1
Cells(k, "C") = i
k = k + 1
Next j
Cells(i, "B") = 1
End If
Next i
End Sub
最下行ｄを求め、増やすのはその下の部分の行にして、ポンインタK
を使って１行増追加するごとにKも１足してます。
あと終了後C列でソートします。
結果
東京11
大阪12
大阪12
大阪12
札幌13
札幌13
福岡14
横浜15
横浜15
B、C列が不要なら削除。
Range("B:C").EntireColumn.Delete
をコードの最後（end SUBの直前）に入れておく。

この回答へのお礼

ありがとうございます。
御礼が遅くなって申し訳ありません。
データを増やして並べ替えとはとても思いつきませんでした。
色々な方法があるのですね。勉強になりました。

お礼日時：2007/07/09 17:38

No.3 ベストアンサー 回答者： Wendy02 回答日時： 2007/07/06 22:21

こんばんは。

これは、記録マクロの延長上にあると思いますから、下から取れば、簡単に出来てしまうと思います。


Sub RowsEntries()
　　Dim i As Long
　　Dim j As Long
　　Application.ScreenUpdating = False '画面の切り替えを止める
　　For i = Range("B65536").End(xlUp).Row To 1 Step -1
　　　 j = Cells(i, 2).Value 'B列の値を取る
　　　　If j > 1 Then
　　　　　　Cells(i, 1).Resize(, 2).Copy
　　　　　　Cells(i, 1).Resize(j - 1).Insert Shift:=xlDown
　　　　　　Cells(i, 2).Resize(j).Value = 1
　　　　End If
　　Next i
　　Application.CutCopyMode = False
　　Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございます。
御礼が遅くなって申し訳ありません。
下から上へ行く方法があるとは。
とてもシンプルで分かりやすい方法ですね。
記述の短さと分かりやすさで20pt付けさせていただきました。
また勉強しなおしてきます。

お礼日時：2007/07/09 17:41