Align two columns of data with blanks

[cdev19]

Simplified example of what I am trying to solve.

Data I have:
Column A / Column B
1 1
2 3
3 <blank>*
4 5
<blank> 7 *
5 *
9 *
* 7
10 9
* 11

<blank>
End result I require:
1 1
2 *<blank>
3 3
4 *
<blank> 5 5
7 7
<blank> 9 9
10 *
* 11

where *<blank> represents an empty cell

It lines up the data that matches, and when there is no match it leaves a blank in the column that doesn't have the data.

One issue is - either column could have more rows of data on a given day (eg. column A has 15 rows and column B has 10 rows on Monday, column A has 12 rows and column B has 15 rows on Tuesday).

Any help would be great appreciated.

Thank you.</blank></blank></blank></blank></blank></blank></blank>

 

[Legacy 14611]

How about something like this?

Sub test()
Dim w, n As Long, a As Range, x As Long
n = Range("A:B").Find("*", after:=[a1], searchdirection:=xlPrevious, searchorder:=xlByRows).Row
w = Range("A1:B" & n)
Range("AA1:AB" & n) = w
Cells(n + 1, 1) = Chr(255): Cells(n + 1, 2) = Chr(255)
Set a = Cells(1, 1).Resize(n + 1, 2)
a.Resize(, 1).Sort a(1, 1), 1, header:=xlNo
a.Resize(, 1).Offset(, 1).Sort a(1, 2), 1, header:=xlNo
Do
x = x + 1
If a(x, 1) > a(x, 2) Then
    a(x, 1).Insert xlDown
ElseIf a(x, 1) < a(x, 2) Then
    a(x, 2).Insert xlDown
End If
If x > 10 ^ 4 Then Exit Do
Loop Until a(x, 1) = Chr(255) And a(x, 1) = Chr(255)
Cells(x, 1).Resize(1, 2).ClearContents
End Sub

This code also copies your original unmodified data from columns A and B to columns AA and AB, in case you need to retrieve it at any time.

It is was written assuming no headers in Col A and B, although easily modified if need be.

 

[cdev19]

Thanks so much for that.

I have had a go at modifying this for a similar purpose to no avail.

Take the above example, but insert a new column to the right of A and to the right of B. So now what used to be Column A and B are now A and C, with two new columns as B and D.

How can I get the macro to test matches in columns A and C, and if not found, move the data in both A and B (or C and D if appropriate) down. Basically, move A/B or C/D as required keeping them in pairs.

Again thanks for your assistance with this.

 

[Legacy 14611]

This matches cols A and C. You should be able to extend it to B and D similarly.

Sub matchemup()
Dim n As Long, a As Range, c As Range, x As Long
n = Cells.SpecialCells(11).Row
Set a = Range("A:A"): Set c = Range("C:C")
a(n + 1) = Chr(255): c(n + 1) = Chr(255)
a.Sort a(1), 1, header:=xlNo
c.Sort c(1), 1, header:=xlNo
Do
x = x + 1
If a(x) > c(x) Then
    a(x).Insert xlDown
ElseIf a(x) < c(x) Then
    c(x).Insert xlDown
End If
If x > 10 ^ 4 Then Exit Do
Loop Until a(x) = Chr(255) And c(x) = Chr(255)
a(x).ClearContents: c(x).ClearContents
End Sub

 

[jmd0103]

Is there a way to do this same function but without having the sort? What if both columns are in the same random order and must stay in that order?

 

[srirbhar5]

Hi the code is excelent i want to change the other columns to be chnaged when the coumn a changes. I.e if column a changes then b also should change can u help me with a macro here

this matches cols a and c. You should be able to extend it to b and d similarly.

sub matchemup()
dim n as long, a as range, c as range, x as long
n = cells.specialcells(11).row
set a = range("a:a"): Set c = range("c:c")
a(n + 1) = chr(255): C(n + 1) = chr(255)
a.sort a(1), 1, header:=xlno
c.sort c(1), 1, header:=xlno
do
x = x + 1
if a(x) > c(x) then
    a(x).insert xldown
elseif a(x) < c(x) then
    c(x).insert xldown
end if
if x > 10 ^ 4 then exit do
loop until a(x) = chr(255) and c(x) = chr(255)
a(x).clearcontents: C(x).clearcontents
end sub