エクセル 関数・VBA 行位置・行数・行挿入

質問

下のようなシートがあり、自動で、発生月ごとのXとYの数値帯の個数を揃えるように（行挿入）
修正したいのですが、どのような方法が考えられますでしょうか？同様のシートが多数あり、
それぞれ数値帯は異なり、それらへも対応させたいのです。

発生月ごとに、XとYの数値帯を比較して、少ない方へ行を追加すれば良いかと思い、関数とVBA
の組合せで何とかならないかと考えたのですが、進みません。

例えば、関数で、発生月ごとのXとYについて、最小値と最大値をそれぞれ比較して、500で割っ
て、足りない行数を算出し、また、それぞれの最小値と最大値のある行位置を特定して、それら
を変数として、VBAで実行させる・・・
最小値と最大値はDMAX（DMIN）で算出できたのですが、数値帯が小さい方へ不足することもあれ
ば、大きい方へ不足することもありますし、差が無い場合もありますし、さらには、行位置の特
定もどうすれば良いか思いつきません。

そもそも、この考え方が不適切なのでしょうか？

お手数ですが、教えてください。

A列に発生月を示す6桁半角数字（例／200512）
B列に種を示す1半角英字（XまたはY）
C列に数値帯を示す500刻みの4または5桁半角数字（例／8000、32500）
※発生月と数値帯は昇順に並んでいます。

　　A　　　　B　　　C
　発生月　　種　　数値帯
　200512　　X　　　9500
　200512　　X　　　10000
　200512　　X　　　10500
　・
　・
　200512　　Y　　　8000
　200512　　Y　　　8500
　200512　　Y　　　9000
　・
　・
　200601　　X　　　10500
　200601　　X　　　11000
　・
　・
　200601　　Y　　　10500
　200601　　Y　　　11000
　・
　・

回答No.2

o_chi_chi · ベストアンサー

#1です。
挿入した行に値を設定するモジュールを追加しました。
エラーに関しては状況がわかりませんので対応していません。
またいろいろなパターンではテストしていないので
頑張って改良してください。
---
Sub mSample()
Dim i As Long
Dim strYM As String

Dim xmx As Long '同一年月のXの最大数値
Dim xmi As Long '同一年月のXの最小数値
Dim ymx As Long '同一年月のYの最大数値
Dim ymi As Long '同一年月のYの最小数値
Dim xed As Long '同一年月のXの最終行
Dim yed As Long '同一年月のYの最終行

'１行目はタイトル欄とする

'最終行を取得
i = Range("A65536").End(xlUp).Row
Do While i > 1
xmx = 0
xmi = 0
ymx = 0
xmi = 0
yed = i
strYM = Cells(i, 1).Value

Do While Cells(i, 1).Value = strYM And i > 1
If Cells(i, 2).Value = "Y" Then
If ymx = 0 Then
'Yの最大数値を取得
ymx = Cells(i, 3).Value
End If
Else
If xmx = 0 Then
xed = i
'Yの最小数値を取得
ymi = Cells(i + 1, 3).Value
'Xの最大数値を取得
xmx = Cells(i, 3).Value
End If
End If
i = i - 1
Loop
'Xの最小数値を取得
xmi = Cells(i + 1, 3).Value

'Xの最大数値が大きいときYの最終行の下に行を挿入
If xmx > ymx Then
Rows(CStr(yed + 1) & ":" & CStr(yed + (xmx - ymx) / 500)).Insert Shift:=xlDown
Call mSet(strYM, "Y", ymx, (xmx - ymx) / 500, 1, yed + 1)
End If
'Yの最小数値が大きいときYの開始行の上に行を挿入
If ymi > xmi Then
Rows(CStr(xed + 1) & ":" & CStr(xed + (ymi - xmi) / 500)).Insert Shift:=xlDown
Call mSet(strYM, "Y", ymi, (ymi - xmi) / 500, -1, xed + (ymi - xmi) / 500)
End If
'Yの最大数値が大きいときXの最終行の下に行を挿入
If xmx < ymx Then
Rows(CStr(xed + 1) & ":" & CStr(xed + (ymx - xmx) / 500)).Insert Shift:=xlDown
Call mSet(strYM, "X", xmx, (ymx - xmx) / 500, 1, xed + 1)
End If
'Xの最小数値が大きいときXの開始行の上に行を挿入
If ymi < xmi Then
Rows(CStr(i + 1) & ":" & CStr(i + (xmi - ymi) / 500)).Insert Shift:=xlDown
Call mSet(strYM, "X", xmi, (xmi - ymi) / 500, -1, i + (xmi - ymi) / 500)
End If
Loop

End Sub

'引数
'発生年月、種、開始数値帯、範囲、増減、開始行
Sub mSet(strYM As String, strSu As String, lngS As Long, lngH As Long, lngD As Long, lngR As Long)
Dim i As Long
Dim s As Long
Dim e As Long
Dim w As Long
w = lngS
'開始行、終了行を設定
If lngD > 0 Then
s = lngR
e = lngR + lngH - 1
Else
s = lngR
e = lngR - lngH + 1
End If
'セルにデータを設定
For i = s To e Step lngD
Cells(i, 1).Value = strYM
Cells(i, 2).Value = strSu
w = w + 500 * lngD
Cells(i, 3).Value = w
Next i
End Sub

お礼

ありがとうございます。シートの結果自体は上手くいきました。
デバック発生箇所については調べてみます。

回答No.1

o_chi_chi

ご希望通りかどうか分かりませんが。。。。
---
Sub mSample()
Dim i As Long
Dim strYM As String

Dim xmx As Long '同一年月のXの最大数値
Dim xmi As Long '同一年月のXの最小数値
Dim ymx As Long '同一年月のYの最大数値
Dim ymi As Long '同一年月のYの最小数値
Dim xed As Long '同一年月のXの最終行
Dim yed As Long '同一年月のYの最終行

'１行目はタイトル欄とする
'最終行を取得
i = Range("A65536").End(xlUp).Row
Do While i > 1
'初期化
xmx = 0
xmi = 0
ymx = 0
xmi = 0
yed = i
strYM = Cells(i, 1).Value
'発生月が同じ間
Do While Cells(i, 1).Value = strYM And i > 1
If Cells(i, 2).Value = "Y" Then
If ymx = 0 Then
'Yの最大数値を取得
ymx = Cells(i, 3).Value
End If
Else
If xmx = 0 Then
xed = i
'Yの最小数値を取得
ymi = Cells(i + 1, 3).Value
'Xの最大数値を取得
xmx = Cells(i, 3).Value
End If
End If
i = i - 1
Loop
'Xの最小数値を取得
xmi = Cells(i + 1, 3).Value

'Xの最大数値が大きいときYの最終行の下に行を挿入
If xmx > ymx Then
Rows(CStr(yed + 1) & ":" & CStr(yed + (xmx - ymx) / 500)).Insert Shift:=xlDown
End If
'Yの最小数値が大きいときYの開始行の上に行を挿入
If ymi > xmi Then
Rows(CStr(xed + 1) & ":" & CStr(xed + (ymi - xmi) / 500)).Insert Shift:=xlDown
End If
'Yの最大数値が大きいときXの最終行の下に行を挿入
If xmx < ymx Then
Rows(CStr(xed + 1) & ":" & CStr(xed + (ymx - xmx) / 500)).Insert Shift:=xlDown
End If
'Xの最小数値が大きいときXの開始行の上に行を挿入
If ymi < xmi Then
Rows(CStr(i + 1) & ":" & CStr(i + (xmi - ymi) / 500)).Insert Shift:=xlDown
End If
Loop
End Sub

お礼

ご回答ありがとうございます。素晴らしいです。試してみます。

補足

試してみたところ、シート上では上手く完了したようですが、下の箇所でデバックとなります。
'Xの最大数値を取得
xmx = Cells(i, 3).Value
行挿入も実行されているのに、何故でしょう？

また、説明不足で申し訳ございませんが、追加された行に、発生月・種・数値帯
の値を入れるためにはどうすれば良いのでしょうか？
発生月と種は、追加の対象となったものと同じ値、数値帯は対象となったところ
から、500刻みで追加された分だけ・・・

度々、お手数おかけしますが、教えてください。