連続した数字で一部飛び飛びの数字がある場合

質問

連続した数字で一部飛び飛びの数字がある場合　行を挿入して数字を記入するにはどうすればいいですか　マクロのコードを作ったのですが
Sub Try1()
Dim r As Range, r2 As Range, c As Range
Dim i As Long
Dim max As Long
Dim min As Long
With ActiveSheet.[A1].CurrentRegion
'[D]列の最後のセル
Set r2 = .Cells(.Rows.Count, "D")
'[D]列データ範囲
Set r = .Range("D2", r2)
'データ 最大 最少
min = r(1).Value
max = r2.Value
ReDim a(min To max) As String
For i = min To max: a(i) = CStr(i): Next 'min ～ max に 番号を振る
For Each c In r
a(c.Value) = "x" '実際にある番号の位置は "x" に書き換える
Next
a = Filter(a, "x", False) 'a配列の中から 「"x"でない」要素を抽出。

r2.Offset(1).Resize(UBound(a) + 1).Value = Application.Transpose(a) '欠損番号を[D]列に追加 ◆
End With
With ActiveSheet.[A1].CurrentRegion
.Sort Key1:=.Columns(4), Header:=xlYes 'Ｄ列で並び替える
End With

End Sub
　min = r(1).Value
の所で型が一致しませんとでます
数字はDれつにあります

回答No.3

tom04

こんばんは！
せっかくコードをお考えのようですが・・・
おそらくこういうコトがご希望だと思います。

Sub Sample1()
Dim k As Long, minRow As Long, maxRow As Long, c As Range
minRow = WorksheetFunction.min(Range("D:D"))
maxRow = WorksheetFunction.max(Range("D:D"))
For k = minRow To maxRow
Set c = Range("D:D").Find(what:=k, LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
Cells(Rows.Count, "D").End(xlUp).Offset(1) = k
End If
Next k
Range("D1").CurrentRegion.Sort key1:=Range("D1"), order1:=xlAscending, Header:=xlYes
End Sub

外していたらごめんなさいね。m（_ _）m

補足

申し訳ありません数字型ではなかったみたいで　◯番みたいに文字も含まれました

回答No.2

mt2008

多分、こういう事かなぁという推測の元、なるべく元のコードをそのままに修正してみました。

1.「With ActiveSheet.[A1].CurrentRegion」はNG
　この書き方では意味がありませんし、あえて書くとしたら
　ActiveSheet.Range("A1").CurrentRegion でしょうが、どのみちActiveSheetが対象だったので削りました。

2.誤：[D]列の最後のセル　→　正：[D]列のデータがある最後のセル
Set r2 = Cells(Rows.Count, "D").End(xlUp)　

3.Sortを修正しました。

Sub Try2()
　　Dim r As Range, r2 As Range, c As Range
　　Dim i As Long
　　Dim max As Long
　　Dim min As Long
　　'[D]列の最後のセル
　　Set r2 = Cells(Rows.Count, "D").End(xlUp)
　　'[D]列データ範囲
　　Set r = Range("D2", r2)
　　'データ 最大 最少
　　min = r(1).Value
　　max = r2.Value
　　ReDim a(min To max) As String
　　For i = min To max: a(i) = CStr(i): Next 'min ～ max に 番号を振る
　　For Each c In r
　　　　a(c.Value) = "x" '実際にある番号の位置は "x" に書き換える
　　Next
　　a = Filter(a, "x", False) 'a配列の中から 「"x"でない」要素を抽出。

　　r2.Offset(1).Resize(UBound(a) + 1).Value = Application.Transpose(a) 　　'欠損番号を[D]列に追加 ◆

　　ActiveSheet.Sort.SortFields.Clear
　　With ActiveSheet.Sort
　　　　.SortFields.Add Key:=Range("D1")
　　　　.SetRange Range("A1").CurrentRegion
　　　　.Header = xlYes
　　　　.Apply
　　End With
End Sub

回答No.1

Asahi2001

一例)として、

Sub test1()
Dim i As Long: i = 2 '開始行
Dim Num As Long: Num = 1 '連番
Dim MyRange As Range
Set MyRange = Range("A1").CurrentRegion　'ソート範囲取得
MyRange.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes　'Ｄ列で昇順ソート
Do While Cells(i, "D").Value <> ""
If Cells(i, "D").Value > Num Then　
Rows(i).Insert　　　　　　　　　　　
Cells(i, "D").Value = Num　　　　　　
End If
Num = Num + 1
i = i + 1
Loop
End Sub