sort in multiple columns

  • Thread starter Thread starter bob
  • Start date Start date
B

bob

hi guys,
how can i sort lists of names in several columns eg: c3:c15,
e3:e15,c18:c31,e18:e31. so that the first names (A...) start in c3 and the
last (...Z) end in e31?

regards
bob
 
One way you can do this is to make a dummy sort column with the formula
in F13
=if(c3<e3,c3,e3) this will put the first name in the cell

copy this to the rest of the range. Sort all three columns using F as
the sort column.

If you need to keep the space C16:E17 for some reason you could put a
dummy value in F16 and F17 and finally cut and paste C16:F17 (AAA or
ZZZ would put it at the top or bottom of the list)

Hope this helps

Mike
 
Does this mean you have 13+13+14+14=54 names spread over 4 ranges?

If yes, I'd add a temporary worksheet, copy those ranges to A1:A54 and sort
there. Then copy|Paste the rows back to the 4 areas in that range (if you need
to).
 
hi dave, those columns should have 15 entries each my mistake. i was hoping
to have this feature happen auto matically as i enter the names. eg: add
another name to a blank cell (anywhere, most likely at the bottom) and it
shuffles amongst the other names to finds its place.

regards
bob
 
But the order of placement into those cells is:

C3:C17 then E3:E17 then C18:C32 then E18:E32

If yes, then right click on the worksheet tab that should have this behavior.
Select view code and paste this in:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRng As Range
Dim myCell As Range
Dim myArray() As Variant
Dim iCtr As Long
Dim TotalElements As Long

If Target.Cells.Count > 1 Then Exit Sub

'change this line to match the cell where you'll do your data entry
If Intersect(Target, Range("a1")) Is Nothing Then Exit Sub

If Trim(Target.Value) = "" Then Exit Sub

Set myRng = Range("C3:C17,E3:E17,C18:C32,E18:E32")

If Application.CountA(myRng) = myRng.Cells.Count Then
MsgBox "No empty cells for new name!"
Beep
Exit Sub
End If

ReDim myArray(1 To myRng.Cells.Count)
myArray(1) = Target.Value
iCtr = 1
For Each myCell In myRng.Cells
If Trim(myCell.Value) <> "" Then
iCtr = iCtr + 1
myArray(iCtr) = myCell.Value
End If
Next myCell
TotalElements = iCtr
Call QuickSort(myArray(), 1, TotalElements)

iCtr = 0
Application.EnableEvents = False
For Each myCell In myRng.Cells
iCtr = iCtr + 1
If iCtr > TotalElements Then
myCell.Value = ""
Else
myCell.Value = myArray(iCtr)
End If
Next myCell

Target.Value = ""
Application.EnableEvents = True

End Sub

Then Insert|Module from the VBE toolbar to insert a general module. Paste this
in:

Option Explicit
Sub QuickSort(SortArray, L, R)
'from Jim Rech
'http://google.com/[email protected]
'one line in your browser

Dim i, j, X, Y
i = L
j = R
X = SortArray((L + R) / 2)

While (i <= j)
While (SortArray(i) < X And i < R)
i = i + 1
Wend
While (X < SortArray(j) And j > L)
j = j - 1
Wend
If (i <= j) Then
Y = SortArray(i)
SortArray(i) = SortArray(j)
SortArray(j) = Y
i = i + 1
j = j - 1
End If
Wend
If (L < j) Then Call QuickSort(SortArray, L, j)
If (i < R) Then Call QuickSort(SortArray, i, R)
End Sub
 
hi dave,
i've tried this

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRng As Range
Dim myCell As Range
Dim myArray() As Variant
Dim iCtr As Long
Dim TotalElements As Long

If Target.Cells.Count > 1 Then Exit Sub

'change this line to match the cell where you'll do your data entry
If Intersect(Target, Range("B3:B17,D3:D17,B20:B34,D20:D34")) Is Nothing Then Exit Sub

If Trim(Target.Value) = "" Then Exit Sub

Set myRng = Range("B3:B17,D3:D17,B20:B34,D20:D34")

If Application.CountA(myRng) = myRng.Cells.Count Then
MsgBox "No empty cells for new name!"
Beep
Exit Sub
End If

ReDim myArray(1 To myRng.Cells.Count)
myArray(1) = Target.Value
iCtr = 1
For Each myCell In myRng.Cells
If Trim(myCell.Value) <> "" Then
iCtr = iCtr + 1
myArray(iCtr) = myCell.Value
End If
Next myCell
TotalElements = iCtr
Call QuickSort(myArray(), 1, TotalElements)

iCtr = 0
Application.EnableEvents = False
For Each myCell In myRng.Cells
iCtr = iCtr + 1
If iCtr > TotalElements Then
myCell.Value = ""
Else
myCell.Value = myArray(iCtr)
End If
Next myCell

Target.Value = ""
Application.EnableEvents = True

End Sub

the range i've used to enter data is the entire range. the only problem is that it enters the data in twice. also this separates the case (eg upper case A-Z come before lower case a-z)

any ideas
regards
bob


bob said:
Thank you heaps Dave,
This will make things a lot easier
regards bob
Click to expand...
 
I thought you said that you were going to enter the data into a different
cell--but maybe you meant another cell in the range (I just reread your other
post and it sounds like I misread it the first time).

But try this in the worksheet module (the general module didn't change):

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRng As Range
Dim myCell As Range
Dim myArray() As Variant
Dim iCtr As Long
Dim TotalElements As Long

If Target.Cells.Count > 1 Then Exit Sub

Set myRng = Range("B3:B17,D3:D17,B20:B34,D20:D34")

'change this line to match the cell where you'll do your data entry
If Intersect(Target, myRng) Is Nothing Then Exit Sub

ReDim myArray(1 To myRng.Cells.Count)
iCtr = 0
For Each myCell In myRng.Cells
If Trim(myCell.Value) <> "" Then
iCtr = iCtr + 1
myArray(iCtr) = myCell.Value
End If
Next myCell
TotalElements = iCtr

Call QuickSort(myArray(), 1, TotalElements)

iCtr = 0
Application.EnableEvents = False
For Each myCell In myRng.Cells
iCtr = iCtr + 1
If iCtr > TotalElements Then
myCell.Value = ""
Else
myCell.Value = myArray(iCtr)
End If
Next myCell

Application.EnableEvents = True

End Sub

bob wrote:

hi dave,
i've tried this

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRng As Range
Dim myCell As Range
Dim myArray() As Variant
Dim iCtr As Long
Dim TotalElements As Long

If Target.Cells.Count > 1 Then Exit Sub

'change this line to match the cell where you'll do your data entry
If Intersect(Target, Range("B3:B17,D3:D17,B20:B34,D20:D34")) Is Nothing
Then Exit Sub

If Trim(Target.Value) = "" Then Exit Sub

Set myRng = Range("B3:B17,D3:D17,B20:B34,D20:D34")

If Application.CountA(myRng) = myRng.Cells.Count Then
MsgBox "No empty cells for new name!"
Beep
Exit Sub
End If

ReDim myArray(1 To myRng.Cells.Count)
myArray(1) = Target.Value
iCtr = 1
For Each myCell In myRng.Cells
If Trim(myCell.Value) <> "" Then
iCtr = iCtr + 1
myArray(iCtr) = myCell.Value
End If
Next myCell
TotalElements = iCtr
Call QuickSort(myArray(), 1, TotalElements)

iCtr = 0
Application.EnableEvents = False
For Each myCell In myRng.Cells
iCtr = iCtr + 1
If iCtr > TotalElements Then
myCell.Value = ""
Else
myCell.Value = myArray(iCtr)
End If
Next myCell

Target.Value = ""
Application.EnableEvents = True

End Sub

the range i've used to enter data is the entire range. the only problem is
that it enters the data in twice. also this separates the case (eg upper case
A-Z come before lower case a-z)

any ideas
regards
bob
Click to expand...
 
Back
Top