Sorting a list according to other list

K

K

I got data in column A and B like see below. As you can see below I
got file paths listed in both columns.

A B……col
C:\David Terry C:\Dean Smith
C:\John Owen C:\Michael Ja
C:\Michael Ja C:\Daivd Terry
C:\Ali Smith C:\John Owen
C:\Karen Seal

I need macro which should sort column B list according to column A
list and results should look like as shown below


A B……col
C:\David Terry C:\David Terry
C:\John Owen C:\John Owen
C:\Michael Ja C:\Michael Ja
C:\Ali Smith
C:\Dean Smith
C:\Karen Seal

Please can any friend can help me on this
 
L

Lars-Åke Aspelin

I got data in column A and B like see below. As you can see below I
got file paths listed in both columns.

A B……col
C:\David Terry C:\Dean Smith
C:\John Owen C:\Michael Ja
C:\Michael Ja C:\Daivd Terry
C:\Ali Smith C:\John Owen
C:\Karen Seal

I need macro which should sort column B list according to column A
list and results should look like as shown below


A B……col
C:\David Terry C:\David Terry
C:\John Owen C:\John Owen
C:\Michael Ja C:\Michael Ja
C:\Ali Smith
C:\Dean Smith
C:\Karen Seal

Please can any friend can help me on this
Click to expand...


Assuming that there are no gaps in the original tables, try the
following macro

Sub K()
amin = 1
amax = Cells(amin, "A").End(xlDown).Row
bmin = 1
bmax = Cells(bmin, "B").End(xlDown).Row
Dim result() As String
ReDim result(amax + bmax)
For b = bmin To bmax
For a = amin To amax
If Cells(b, "B") = Cells(a, "A") Then
result(a) = Cells(a, "A")
Cells(b, "B") = ""
End If
Next a
Next b
For b = bmin To bmax
If Not Cells(b, "B") = "" Then
amax = amax + 1
result(amax) = Cells(b, "B")
End If
Next b
For b = 1 To amax
Cells(b, "B") = result(b)
Next b
End Sub

Hope this helps / Lars-Åke
 
K

K

Hi Lars thank for replying. your macro work brilliant. i am bit
curious that how you created such a clever macro. Is it possible for
you to explain your macro to me bit in detail just for my knowledge.
many thanks
 
L

Lars-Åke Aspelin

Hi Lars thank for replying. your macro work brilliant. i am bit
curious that how you created such a clever macro. Is it possible for
you to explain your macro to me bit in detail just for my knowledge.
many thanks
Click to expand...


The macro consists of three parts; I, II, and III

Part I: A double loop where each entry in table b is either
- copied to the result vector and then cleared from table b if it is
also found in table a
- or left in table b if there is no matching entry in table a

Part II: A single loop where the entries of table b that has not been
cleared, ie were not also found in table a is copied to the end of the
result vector. The end of the result vector is gradually increasing.

Part III: A single loop where the result vector is stored back as the
new table b which is the requested result of the macro.


The part II loop could be avoided by adding the corresponding code to
the outer loop of part I and the inner loop of part I could be exited
when a match has been found, but unless the size of the tables are not
tens of thousands of rows there is not much time to be gained by those
optimizations.

That's all there is to it. Hope that makes sence. / Lars-Åke
 
K

K

Thanks lot lars for the explanion. just last question. what changes
can be done in your macro if i have data like below


A B……col
C:\David Terry C:\Dean Smith (MC) - 23
C:\John Owen C:\Michael Ja - 778
C:\Michael Ja C:\Daivd Terry (ds)
C:\Ali Smith C:\John Owen - x23
C:\Karen Seal - (CC)


and i need result like below


A B……col
C:\David Terry C:\David Terry (ds)
C:\John Owen C:\John Owen - x23
C:\Michael Ja C:\Michael Ja - 778
C:\Ali Smith
C:\Dean Smith (MC) - 23
C:\Karen Seal - (CC)


basically same name file path should be in same row
 
L

Lars-Åke Aspelin

Thanks lot lars for the explanion. just last question. what changes
can be done in your macro if i have data like below


A B……col
C:\David Terry C:\Dean Smith (MC) - 23
C:\John Owen C:\Michael Ja - 778
C:\Michael Ja C:\Daivd Terry (ds)
C:\Ali Smith C:\John Owen - x23
C:\Karen Seal - (CC)


and i need result like below


A B……col
C:\David Terry C:\David Terry (ds)
C:\John Owen C:\John Owen - x23
C:\Michael Ja C:\Michael Ja - 778
C:\Ali Smith
C:\Dean Smith (MC) - 23
C:\Karen Seal - (CC)


basically same name file path should be in same row
Click to expand...


Try changeing these two lines of code

If Cells(b, "B") = Cells(a, "A") Then
result(a) = cells(a,"A")

to these two lines

If InStr(Cells(b, "B"), Cells(a, "A")) > 0 Then
result(a) = Cells(b, "B")

The exact comparison, equality, is changed to just see if the entry
in table a is the same as the start/beginning of the entry in table b.
The result is taken from table b. (In the previous version it was not
important from which table the result was taken as the table entries
were equal.)

Hope this helps / Lars-Åke
 
K

K

Hi lars. its not working as by adding these new lines it add rows on
the top of column B data instead of putting same name file paths in
same row. any advise
 
L

Lars-Åke Aspelin

Hi lars. its not working as by adding these new lines it add rows on
the top of column B data instead of putting same name file paths in
same row. any advise
Click to expand...

The described problem will occur e.g. if you have leading and/or
trailing blanks in the items in column a and/or column b.

Try removing such blanks with Trim(), like this for the two lines

If InStr(Cells(b, "B"), Trim(Cells(a, "A"))) = 1 Then
result(a) = Cells(b, "B")

I repeat the full macro here for convenience

Sub K()
amin = 1
amax = Cells(amin, "A").End(xlDown).Row
bmin = 1
bmax = Cells(bmin, "B").End(xlDown).Row
Dim result() As String
ReDim result(amax + bmax)
For b = bmin To bmax
For a = amin To amax
If InStr(Trim(Cells(b, "B")), Trim(Cells(a, "A"))) = 1 Then
result(a) = Cells(b, "B")
Cells(b, "B") = ""
End If
Next a
Next b
For b = bmin To bmax
If Not Cells(b, "B") = "" Then
amax = amax + 1
result(amax) = Cells(b, "B")
End If
Next b
For b = 1 To amax
Cells(b, "B") = result(b)
Next b
End Sub

Hope this helps / Lars-Åke
 
L

Lars-Åke Aspelin

sorry to be pain but your macro still not working. please see my excel
file in below link in which i explained every thing.
http://www.mediafire.com/?sharekey=68e40059f0508c1b08f8df73f2072ed6e04e75f6e8ebb871
Click to expand...


Well, that explains it.
You have items starting with C:\ in table a
and items starting with F:\ in table b.
As C is not the same as F, there is no match.

To skip the 3 first (non blank) characters from the comparison use the
Mid function like this:

If InStr(Mid(Trim(Cells(b, "B")), 4), Mid(Trim(Cells(a, "A")), 4)) = 1
Then

Sub K()
amin = 1
amax = Cells(amin, "A").End(xlDown).Row
bmin = 1
bmax = Cells(bmin, "B").End(xlDown).Row
Dim result() As String
ReDim result(amax + bmax)
For b = bmin To bmax
For a = amin To amax
If InStr(Mid(Trim(Cells(b, "B")), 4), Mid(Trim(Cells(a, "A")),
4)) = 1 Then
result(a) = Cells(b, "B")
Cells(b, "B") = ""
End If
Next a
Next b
For b = bmin To bmax
If Not Cells(b, "B") = "" Then
amax = amax + 1
result(amax) = Cells(b, "B")
End If
Next b
For b = 1 To amax
Cells(b, "B") = result(b)
Next b
End Sub

Hope this helps / Lars-Åke
 
L

Lars-Åke Aspelin

Well, that explains it.
You have items starting with C:\ in table a
and items starting with F:\ in table b.
As C is not the same as F, there is no match.

To skip the 3 first (non blank) characters from the comparison use the
Mid function like this:

If InStr(Mid(Trim(Cells(b, "B")), 4), Mid(Trim(Cells(a, "A")), 4)) = 1
Then

Sub K()
amin = 1
amax = Cells(amin, "A").End(xlDown).Row
bmin = 1
bmax = Cells(bmin, "B").End(xlDown).Row
Dim result() As String
ReDim result(amax + bmax)
For b = bmin To bmax
For a = amin To amax
If InStr(Mid(Trim(Cells(b, "B")), 4), Mid(Trim(Cells(a, "A")),
4)) = 1 Then
result(a) = Cells(b, "B")
Cells(b, "B") = ""
End If
Next a
Next b
For b = bmin To bmax
If Not Cells(b, "B") = "" Then
amax = amax + 1
result(amax) = Cells(b, "B")
End If
Next b
For b = 1 To amax
Cells(b, "B") = result(b)
Next b
End Sub

Hope this helps / Lars-Åke
Click to expand...


Sorry, I didn't notice that the paths were different to.
So you have to replace the two 4 with the respective position of the
last \ in your items.
Moreover, the .xlsx part also has to be removed from the a table items
before the comparison.

The If statement is thus getting more complex, like this

If InStr(Mid(Trim(Cells(b, "B")), _
find_last_char(Trim(Cells(b, "B")), "\") + 1), _
Mid(Trim(Cells(a, "A")), find_last_char(Trim(Cells(a, "A")),
"\") + 1, _
find_last_char(Trim(Cells(a, "A")), ".") - _
find_last_char(Trim(Cells(a, "A")), "\") - 1)) = 1 Then

where I have implemented the following function to find the last
occurence of "\" and ".".

Function find_last_char(s As String, ch As String)
p = 0
For i = 1 To Len(s)
If Mid(s, i, 1) = ch Then p = i
Next i
find_last_char = p
End Function

Here is the full macro again

Sub K()
amin = 1
amax = Cells(amin, "A").End(xlDown).Row
bmin = 1
bmax = Cells(bmin, "B").End(xlDown).Row
Dim result() As String
ReDim result(amax + bmax)
For b = bmin To bmax
For a = amin To amax
If InStr(Mid(Trim(Cells(b, "B")), _
find_last_char(Trim(Cells(b, "B")), "\") + 1), _
Mid(Trim(Cells(a, "A")), find_last_char(Trim(Cells(a, "A")),
"\") + 1, _
find_last_char(Trim(Cells(a, "A")), ".") - _
find_last_char(Trim(Cells(a, "A")), "\") - 1)) = 1 Then
result(a) = Cells(b, "B")
Cells(b, "B") = ""
End If
Next a
Next b
For b = bmin To bmax
If Not Cells(b, "B") = "" Then
amax = amax + 1
result(amax) = Cells(b, "B")
End If
Next b
For b = 1 To amax
Cells(b, "B") = result(b)
Next b
End Sub

Hope this helps / Lars-Åke
 
J

joel

there are two postings for this request. I posted this code at th
other posting

Sub SortColumns()

Set sht1 = Sheets("Sheet1")
Set Sht2 = Sheets("Sheet2")


'copy column A to sheet 2
sht1.Columns("A").Copy _
Destination:=Sht2.Columns("A")

With Sht2
'lookup column A on sht2 with column b on sht1
RowCount = 1
Do While .Range("A" & RowCount) <> ""
'remove file extension
FName = .Range("A" & RowCount)
FName = Left(FName, InStrRev(FName, ".") - 1)
'remove Folder name
FName = Mid(FName, InStrRev(FName, "\") + 1)


'remove file extension from filename
Set c = sht1.Columns("B").Find(what:=FName, _
LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
.Range("B" & RowCount) = c
'put Match into column C on sheet 1
c.Offset(0, 1).Value = "X"
End If
RowCount = RowCount + 1
Loop
End With


End Su
 
K

K

Thanks lot Lars it worked like charm. I tested it and it exactly
doing what i need. you are genious man. thanks again
 
K

K

Thanks lot Joel. i tried your code as well and it works superb as
well. i cant believe i got two macros to do this thing.man
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Sorting Data 11
modified pivot table using a macro 2
Extract Name from Text 4
Macro for Special Sorting 4
Re posting Please help (Macro for Special Sorting) 4
Total columns Based on another cells value 4
Convert Full name in Intials 2
Open files by looking at list names in column A 2

Top