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.

Krishnakumar

Well-known Member
Joined
Feb 28, 2003
Messages
2,615
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
Joined
Feb 9, 2005
Messages
74
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
Joined
Jan 16, 2006
Messages
1,624
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
 

pgc01

MrExcel MVP
Joined
Apr 25, 2006
Messages
19,884

ADVERTISEMENT

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
 

agihcam

Well-known Member
Joined
Jan 16, 2006
Messages
1,624
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
Joined
Apr 25, 2006
Messages
19,884
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
 

Forum statistics

Threads
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.
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
Top