would vb or an expression solve this number matching query?

leigh_ashlin

Board Regular
Joined
Feb 9, 2005
Messages
74
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.
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
 
Upvote 0
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
 
Upvote 0
Hi -
Try this experiment;
Code:
Sub sample()
Dim i, ii, iii As Long
Dim a, b, c, d As String
Application.ScreenUpdating = False
Sheets.Add before:=Sheets(1)
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")
Application.DisplayAlerts = False
Sheets("temp").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Hi leigh

Please try:

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
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,211
Members
448,554
Latest member
Gleisner2

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Back
Top