EXCEL Insert missing numbers for sequence with VBA code

DENIS

New member
Joined
Jun 2, 2014
Messages
1
Reaction score
0
Points
0
Need help to modify this script from ExtendOffice It inserts rows of missed data in sequence of rows , but do it only for 2 columns ID and NAME. How i need to modify this script that it works with different number of Columns?

ID NAME NEW
1 name1 new1
3 name3 new3
5 name4 new4
6 name5 new5

ID NAME NEW
1 name1 new1
2
3 name3 new3
4
5 name4 new4
6 name5 new5

Code:
SubInsertValueBetween()[COLOR=#323232][FONT=Consolas]'Update 20130825[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Dim WorkRng As Range[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Dim Rng As Range[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Dim outArr As Variant[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Dim dic As Variant[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Set dic = CreateObject("Scripting.Dictionary")[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]'On Error Resume Next[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]xTitleId = "KutoolsforExcel"[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Set WorkRng = Application.Selection[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]num1 = WorkRng.Range("A1").Value[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]num2 = WorkRng.Range("A" & WorkRng.Rows.Count).Value[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]interval = num2 - num1[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]ReDim outArr(1 To interval + 1, 1 To 2)[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]For Each Rng In WorkRng[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]dic(Rng.Value) = Rng.Offset(0, 1).Value[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Next[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]For i = 0 To interval[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]outArr(i + 1, 1) = i + num1[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]If dic.Exists(i + num1) Then[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]outArr(i + 1, 2) = dic(i + num1)[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Else[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]outArr(i + 1, 2) = ""[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]End If[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]Next[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]With WorkRng.Range("A1").Resize(UBound(outArr, 1), UBound(outArr, 2))[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas].Value = outArr[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas].Select[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]End With[/FONT][/COLOR]
[COLOR=#323232][FONT=Consolas]End Sub[/FONT][/COLOR]
 

Bob Phillips

Super Moderator
Staff member
Joined
Mar 21, 2011
Messages
1,942
Reaction score
0
Points
36
Excel Version(s)
O365
Code:
Sub InsertValueBetween()Dim lastrow As Long
Dim gap As Long
Dim i As Long, ii As Long


    Application.ScreenUpdating = False
    
    With ActiveSheet
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = lastrow To 3 Step -1
        
            gap = .Cells(i, "A").Value - .Cells(i - 1, "A").Value
            If gap > 1 Then
            
                .Rows(i).Resize(gap - 1).Insert
            End If
        Next i
        
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Cells(3, "A").Value = .Cells(2, "A").Value + 1
        .Cells(2, "A").Resize(2).AutoFill .Cells(2, "A").Resize(lastrow - 1)
    End With
End Sub
 
Top