# would vb or an expression solve this number matching query?

#### leigh_ashlin

##### Board Regular
Hi there, can somebody write me a piece of fandango vb that is smart enough sort two lists of numbers and create gaps where there are numbers that do not match in either column?

This would be my raw data:
Book1
ABCD
111
222
334
445
576
688
799
Sheet1

And this would be the expected result:
Book1
ABCD
111
222
33
444
55
66
77
888
999
Sheet1

Alternatively, is there a fancy expression that can do this?

### Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

#### Krishnakumar

##### Well-known Member
Hi,

Not an elegant one..

Code:
``````Sub test()
Dim r As Long
r = Cells(Rows.Count, "A").End(xlUp).Row
For i = r To 1 Step -1
If Cells(i, 1) <> Cells(i, 4) Then
If Cells(i, 1) < Cells(i, 4) Then
Cells(i + 1, 1).Insert Shift:=xlDown
Cells(i, 4).Insert Shift:=xlDown
If Cells(i + 1, 4) = Cells(i + 2, 1) Then
Rows(i + 1).Delete
Cells(i + 1, 4) = Cells(i + 1, 1)
End If
Else
Cells(i, 1).Insert Shift:=xlDown
Cells(i + 1, 4).Insert Shift:=xlDown
If Cells(i + 1, 1) = Cells(i + 2, 4) Then
Rows(i + 1).Delete
Cells(i + 1, 1) = Cells(i + 1, 4)
End If
End If
End If
Next i
End Sub``````

HTH

#### leigh_ashlin

##### Board Regular
Wow this worked great but I left out a column in my haste. There is an extra column that also needs the same formatting as follows:

This would be the original data:
Book1.xls
ABCDE
111A
222B
334C
445D
576E
688F
799G
Sheet1

This would be the output:
Book1.xls
ABCDE
111A
222B
33
444C
55D
66E
77
888F
999G
Sheet1

#### agihcam

##### Well-known Member
Hi -
Try this experiment;
Code:
``````Sub sample()
Dim i, ii, iii As Long
Dim a, b, c, d As String
Application.ScreenUpdating = False
Sheets(1).Name = "temp"
Sheets("Sheet1").Select
a = 1
b = Range("a" & Rows.Count).End(xlUp).Value
c = 1
d = Range("d" & Rows.Count).End(xlUp).Value
Sheets("temp").Select
Range("a1").Value = a
For i = 2 To b
Cells(i, "a").Value = Cells(i - 1, "a").Value + 1
Next
Range("d1").Value = c
For i = 2 To d
Cells(i, "d").Value = Cells(i - 1, "d").Value + 1
Next
For ii = 1 To Range("a" & Rows.Count).End(xlUp).Row
With Sheets("Sheet1").Columns("a")
Set c = .Find(Cells(ii, "a").Value, , , xlWhole)
If c Is Nothing Then
Cells(ii, "a").ClearContents
End If
End With
Next

For ii = 1 To Range("d" & Rows.Count).End(xlUp).Row
With Sheets("Sheet1").Columns("d")
Set c = .Find(Cells(ii, "d").Value, , , xlWhole)
If c Is Nothing Then
Cells(ii, "d").ClearContents
Else
Cells(ii, "e").Value = c.Offset(, 1).Value

End If
End With
Next
For iii = 1 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
If Cells(iii, "a").Value = "" And Cells(iii, "d").Value = "" Then
Rows(iii).Delete
End If
Next
ActiveSheet.Cells.Copy Sheets("Sheet1").Range("a1")
Sheets("temp").Delete
Application.ScreenUpdating = True
End Sub``````

#### pgc01

##### MrExcel MVP

Hi leigh

Code:
``````Sub CreateGaps()
Dim lRow As Long

lRow = 1
Do While ((Range("A" & lRow) <> "") Or (Range("D" & lRow) <> ""))
If Range("A" & lRow) > Range("D" & lRow) Then
Range("A" & lRow).Insert shift:=xlDown
ElseIf Range("A" & lRow) < Range("D" & lRow) Then
Range("D" & lRow).Resize(, 2).Insert
End If
lRow = lRow + 1
Loop
End Sub``````

Hope this helps
PGC

#### agihcam

##### Well-known Member
great code PGC, clean and simple.
i've played around with this post and changing the data layout to something like this, ofcourse, this was not mentioned by the OP, but just in case.
Book3
ABCDE
121A
243B
354C
495D
56E
68F
Sheet1

based on that data sample, i've got endless loop running your code.

#### pgc01

##### MrExcel MVP
Hi agihcam

Thanks for you comments and for posting the data sample that causes the code to fail. You are right, the condition should be an And instead of an Or.

I hope that now it's correct.

Best regards
PGC

Code:
``````Sub CreateGaps()
Dim lRow As Long

lRow = 1
Do While ((Range("A" & lRow) <> "") And (Range("D" & lRow) <> ""))
If Range("A" & lRow) > Range("D" & lRow) Then
Range("A" & lRow).Insert shift:=xlDown
ElseIf Range("A" & lRow) < Range("D" & lRow) Then
Range("D" & lRow).Resize(, 2).Insert
End If
lRow = lRow + 1
Loop
End Sub``````

Replies
1
Views
93
Replies
0
Views
177
Replies
0
Views
101
Replies
2
Views
511
Replies
4
Views
61

1,137,366
Messages
5,681,068
Members
419,950
Latest member
BeckiJae

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back