sorting a row of strings

[wlan11g]

Hey guys,
------
I need help in programming a simple row search within a list that searches for key strings within a current row, and if found, place that cell and its adjacent cell in sorted columns

below is some pseudo code for how i think the program should look like but see the example worksheet for how it should eventually look like on a spreadsheet.
------

i=1; 'start at 1st row in list
j=1; 'start at 1st column in list
'define list size
end_list_row=x 'x as integer
end_list_column=y 'y as integer

for cell_row=i:end_list_row 'scan each row in list
	for cell_column j:end_list_column 'scan each column in list on current row
		if(cell(i,j)=='string1') 'found key string1!
			'move current cell and adjacent cell (data) to cell with pre-defined column m
			move [cell(i,j) & cell(i,j+1)] to [cell(i,m) & cell(i,m+1)]
		
		if(cell(i,j)=='string2') 'found key string2!
			'move current cell and adjacent cell (data) to cell with pre-defined column n
			move [cell(i,j) & cell(i,j+1)] to [cell(i,n) & cell(i,n+1)]

		if(cell(i,j)=='string3') 'found key string3!
			'move current cell and adjacent cell (data) to cell with pre-defined column k
			move [cell(i,j) & cell(i,j+1)] to [cell(i,k) & cell(i,k+1)]

		...etc...
	end
end

Few notes:

- Each key string cell will always have a corresponding data cell adjacent to it
- Each key string cell will only appear at most once per row
- The key strings are usually out of order
- Rows will need to be preserved
- Each row will have at least one key string
- Sorting the rows can be done within the same worksheet, or a new worksheet, but again, the rows need not be changed.

Thanks in advance!

[JBeaucaire]

Put your initial data set onto a sheet without all that stuff around it, so the first column of data starts at A1. Then try this macro:

Option Explicit

Sub SpecialSort()
'JBeaucaire  (12/26/2009)
Dim r As Long, NC As Long
Dim x As Long, y As Long
Dim rfind As Range
x = Range("A1").SpecialCells(xlCellTypeLastCell).Row
y = Range("A1").SpecialCells(xlCellTypeLastCell).Column
NC = y + 2

On Error Resume Next

For r = 1 To x
    Set rfind = Range(Cells(r, 1), Cells(r, y)).Find("string1", After:=Cells(r, y), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not rfind Is Nothing Then Range(rfind, rfind.Offset(0, 1)).Copy Cells(r, NC)
    
    Set rfind = Range(Cells(r, 1), Cells(r, y)).Find("string2", After:=Cells(r, y), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not rfind Is Nothing Then Range(rfind, rfind.Offset(0, 1)).Copy Cells(r, NC + 2)

    Set rfind = Range(Cells(r, 1), Cells(r, y)).Find("string3", After:=Cells(r, y), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not rfind Is Nothing Then Range(rfind, rfind.Offset(0, 1)).Copy Cells(r, NC + 4)

Next r

Range("A1", Cells(x, y + 1)).Delete xlShiftToLeft
        
End Sub

[wlan11g]

Thanks JBeaucaire,

all working sweetly.

[JBeaucaire]

Glad to help...

If that takes care of your need, be sure to EDIT your original post, click Go Advanced and mark the PREFIX box [SOLVED].


(Also, use the blue "scales" icon in our posts to leave Reputation Feedback, it is appreciated. It is found across from the "time" in each of our posts.)