Sorting newspaper-style

I am looking to use this code to help sort my spreadsheet. It's exactly what I'm looking for except for one small piece. I also have some pictures inserted into my cells that I need to follow the sort when I run this macro. I have the pictures set up to move and size with cells but for some reason when I fire this macro the pictures don't move with the text in those cells. Is there anything you can add to your code in order to make the pictures go with the sort?
Sub SortAllRangeData()
   ' Place column header for temporary sort area.
   Range("IV1").Value = "Numbers"
   
   ' Move numbers to temporary sort location.
   For Each cell In Selection
      Range("iv65536").End(xlUp).Offset(1, 0) = cell.Value
   Next cell
   
   ' Sort numbers in ascending order.
   Range("IV1", Range("IV1").End(xlDown)).Sort Key1:=Range("IV2"),  _
   Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
   ' Move sorted data back to original sheet location.
 
   Selection(1, 1).Activate ' Make sure the ActiveCell is the
                            ' top left of Selection first.
   CCnt = Selection.Columns.Count
   RCnt = Selection.Rows.Count
   CellCnt = Selection.Cells.Count
   Tcell = 2
   For c = 1 To CCnt
     For r = 1 To RCnt
If Range("iv" & Tcell).Hyperlinks.Count > 0 Then
        Range(ActiveCell.Address).Offset(r - 1, c - 1).Hyperlinks.Add _
        Range(ActiveCell.Address).Offset(r - 1, c - 1), Range("iv" & Tcell).Hyperlinks(1).Address, , , Range("iv" & Tcell).Hyperlinks(1).TextToDisplay
Else
        Range(ActiveCell.Address).Offset(r - 1, c - 1).Value =  _
        Range("iv" & Tcell).Value
End If
        Tcell = Tcell + 1
     Next r
   Next c
   
   ' Clean up temporary sort location.
   Range("IV1", Range("IV1").End(xlDown)).Clear
End Sub

Open in new window

Squirrel70Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

ahammarCommented:
Although I am using Excel 2003 at the moment, I can duplicate your problem if the pictures are bigger than the cell and extend into another cell that is being sorted, but if the pictures outer edges are inside the cell, then they move with the cells fine.  You might check to make sure the pictures outer boundries are inside the cell that is being moved.
If that is something you can't do, or that is not the problem, then can you upload a sample with the code that does not work for you so we can test, troubleshoot and maybe change it to work for you...in 2003 format
:-)
Albert
0
Squirrel70Author Commented:
Hello. Thank you for the response. The pictures are smaller than the cell. I shrunk them a bit more just to be sure and then fired the code again. Still didn't work. I uploaded a sample for you. As you can see in my file I have 4 cells that have names in them. 2 of them have pictures in them as well. What I'm trying to do is sort the employees by name and picture. I put the name in the cell behind the picture so the code can use the name to sort the employees.
I'm using 2007 but the file is in compatible mode so it can also be used in earlier versions. Thank you for your help

Larry
Employee-Composite-2008-BC-Rev1.xls
0
ahammarCommented:
Hi Larry,
From what I can tell, you want to sort each column seperately...is that correct?

If so, then try this macro.  It does however require that every cell in row A that you want sorted to have something in it.  Right now it starts in A1, goes across the sheet until it finds the first blank cell in row 1, then stops...sorting each column as it goes...You will have to let me know of any more requirements, changes, or if it's not what you were wanting...
I did not study your code to see exactly what it does...I just wrote a macro to do what I think you are wanting...
Just keep me posted and I'll continue to help if you need me to until this is working the way you want it to...

Note:  This sorts in ascending order, and since the file you sent me was already in ascending order, it doesn't do anything.  You will have to manually sort the columns in descending order (or somehow scramble them) so that you can see how it works...

Side Note: Near as I can tell, it doesn't appear that your pictures were not moving with the cells...it appears more like the cells were not moving...but I'm not using Excel 2007 (which I do have at home, but not where I am at right now), and I didn't test your code much, so I can't say that for sure.

:-)
Albert

Sub SortEmployees()
Dim r As Range
Dim rWhole As Range
Set r = Range("A1")
Do Until r.Value = ""
    Set rWhole = r.EntireColumn
    rWhole.Sort Key1:=Range(Cells(1, r.Column), Cells(1, r.Column)), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
    Set r = r.Offset(0, 1)
Loop
 
End Sub

Open in new window

0
Cloud Class® Course: Microsoft Exchange Server

The MCTS: Microsoft Exchange Server 2010 certification validates your skills in supporting the maintenance and administration of the Exchange servers in an enterprise environment. Learn everything you need to know with this course.

Squirrel70Author Commented:
Hi Albert,

What I'm actually looking to do is sort all my columns by the employees name. Once this is complete I will have 5 columns and 8 or 9 rows. I want to be able to start in column A and sort the employees names all the way through to column E. So I'm looking to sort all my columns together alphabetically by the employee's last name. Hope that makes sense as to what I'm looking to do. The code that I had was working but it just wasn't moving the pictures along with the text behind them.
0
ahammarCommented:
Ok...
I think I see what you are doing now...You aren't just sorting, you are completely rearanging the entire selection...you want to take the entire selection that you select...then have them sort back into the same selection, going down the first column however many rows you had selected, then moving to the next column, going down however many rows you had selected again, then the next column and so on...and putting the cells in that order alphebetically..

I'm going to inspect your code more and work on it right now...

:-)
Albert
0
Squirrel70Author Commented:
Thank you Albert. I think the code was working but it just wasn't taking the pictures with it.
0
ahammarCommented:
Ok...I used your same basic idea, but a different approach on moving the cells.  It moves the cells over to the sorting column, sorts them (in descending order though), then moves them back again (backwards so that they will then be in ascending order)...it seems to work fine....if I got what you want right this time that is...
The macro is fairly simple and short, so you shouldn't have to much problem following the code...
There is 1 requirement (at least for now)...
Your selection has to include range A1, but I think that's what you had in mind anyway...

Here is the code:

:-)
Albert

Sub SortAllRangeData()
Dim CCnt As Integer
Dim rCnt As Long
 
   ' Place column header for temporary sort area.
   Range("IV1").Value = "Numbers"
   
   ' Move numbers to temporary sort location.
   For Each cell In Selection
      cell.Cut Destination:=Range("iv65536").End(xlUp).Offset(1, 0)
   Next cell
   
 
   ' Sort numbers in descending order.
   Range("IV1", Range("IV1").End(xlDown)).Sort Key1:=Range("IV2"), _
   Order1:=xlDescending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
 For CCnt = 1 To Selection.Columns.Count
    For rCnt = 1 To Selection.Rows.Count
        Range("iv65536").End(xlUp).Cut Cells(rCnt, CCnt)
    Next rCnt
Next CCnt
 
End Sub

Open in new window

0
ahammarCommented:
Also...and you would probably see this on your own...but there is no need to clear the sort column in column IV since the cells are being cut from there...unless you want to clear IV1 which has the heading in it.  I didn't add code to do that...

:-)
Albert
0
Squirrel70Author Commented:
That worked perfectly! Thank you very much Albert! It was exactly what I was looking for.
One quick follow up question. Is there a way to add something to the code to center the pictures in the cell after they are sorted? It's a bit of a pain to try and get all the pictures centered exactly the same.
0
Squirrel70Author Commented:
One minor glitch - I think. If I have 5 rows in column A, B, & C and only 4 rows in column D and I highlight everything including the emtpy row 5 in column D and run the code it puts the word "numbers" in the empty cell. How can I remove this and always put the blank cell at the bottom of the last column without the word "numbers"? I'm just thinking that this could happen if we add new employees and not all the columns align with the same amount of rows. I would always want the empty cells to sort the bottom of the last column.
0
ahammarCommented:
Ok...I fixed that problem....I never even thought of that.  I just put a temp value in the blank cells of "zzzzzzzz" (to make sure they get put at the end), then remove them after the cells get moved back...
That way you can have an empty cell anywhere in your selection, and it will put it at the end...
I also added code to turn ScreenUpdating off, then back on again to make the code faster...


Also...centering a picture in a cell is easy when you know which picture goes with each cell, but since the picture names are unknown, I need to see if there is a way to automatically tell which picture belongs to which cell...I'll work on that...that's an interesting problem...but I might not be back right away on that one...

Here is the revised code:

Sub SortAllRangeData()
Dim CCnt As Integer
Dim rCnt As Long
Dim LastCcnt As Long
 
Application.ScreenUpdating = False
 
Columns("IV:IV").Delete
 
   ' Place column header for temporary sort area.
   Range("IV1").Value = "Numbers"
   
   ' Move numbers to temporary sort location.
   For Each cell In Selection
      If cell.Value = "" Then cell.Value = "zzzzzzz"
      cell.Cut Destination:=Range("iv65536").End(xlUp).Offset(1, 0)
   Next cell
   
 
   ' Sort numbers in descending order.
   Range("IV1", Range("IV1").End(xlDown)).Sort Key1:=Range("IV2"), _
   Order1:=xlDescending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
   
 For CCnt = 1 To Selection.Columns.Count
    For rCnt = 1 To Selection.Rows.Count
        Range("iv65536").End(xlUp).Cut Cells(rCnt, CCnt)
    Next rCnt
Next CCnt
 
   For Each cell In Selection
      If cell.Value = "zzzzzzz" Then cell.Value = ""
   Next cell
 
Application.ScreenUpdating = True
End Sub

Open in new window

0
Squirrel70Author Commented:
Thanks for the update Albert. It's working great now. Thank you for your help. It's greatly appreciated. Isn't there a way to just tell all the pictures to automatically center on the cell it lands on without knowing the names of the pictures? Thanks for working on this as well. I'm going to finish adding all my employees into the file while you work on that. No extreme rush on it. It's going to take me some time to gather all the other data.

Thanks Again!
Larry
0
Squirrel70Author Commented:
I did find this code that will center a picture but you need to specify the cell location and I believe also the picture. Maybe this could help you with the code?
Sub aTest()
     
    CenterMe ActiveSheet.Shapes(1), Range("B1")
     
End Sub
 
Sub CenterMe(Shp As Shape, OverCells As Range)
     
    With OverCells
        Shp.Left = .Left + ((.Width - Shp.Width) / 2)
        Shp.Top = .Top + ((.Height - Shp.Height) / 2)
    End With
End Sub

Open in new window

0
ahammarCommented:
Hi Larry,
You are welcome...it is my pleasure to help out here...I hope you will give me a good grade when you are happy with this question being answered

That code looks like it would work fine...as long as you knew the name of the picture....and it would also only work on 1 picture at a time...

But I did come up with something...I could of thought of this a while ago if I wouldn't have been thinking backwards...(I've had a lot going on today)..
I was trying to figure out how to tell which picture was associated with each cell, when all I had to do was do it the other way around...associate each cell with a picture...which I knew how to do all along...massive brain fart on my part...

Anyway..here is the new code in it's entirity...
It does the same as before, then centers the pictures when it's done...but...it will only work right if each picture is smaller than it's cell both directions, and the top left corner of the picture has to be inside the cell, which it should be anyway if you get all the picture anywhere inside the cell.
I tested this, but not thoroughly, but it should work fine...

:-)
Albert

Sub SortAllRangeData()
Dim CCnt As Integer
Dim rCnt As Long
Dim LastCcnt As Long
Dim s As Shape
Dim r As Range
 
 
 
Application.ScreenUpdating = False
 
Columns("IV:IV").Delete
 
   ' Place column header for temporary sort area.
   Range("IV1").Value = "Numbers"
   
   ' Move numbers to temporary sort location.
   For Each cell In Selection
      If cell.Value = "" Then cell.Value = "zzzzzzz"
      cell.Cut Destination:=Range("iv65536").End(xlUp).Offset(1, 0)
   Next cell
   
 
   ' Sort numbers in descending order.
   Range("IV1", Range("IV1").End(xlDown)).Sort Key1:=Range("IV2"), _
   Order1:=xlDescending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
   
 For CCnt = 1 To Selection.Columns.Count
    For rCnt = 1 To Selection.Rows.Count
        Range("iv65536").End(xlUp).Cut Cells(rCnt, CCnt)
    Next rCnt
Next CCnt
 
   For Each cell In Selection
      If cell.Value = "zzzzzzz" Then cell.Value = ""
   Next cell
 
For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, Selection) Is Nothing Then
        Set r = s.TopLeftCell
        s.Left = r.Left + ((r.Width - s.Width) / 2)
        s.Top = r.Top + ((r.Height - s.Height) / 2)
    End If
Next s
 
 
Application.ScreenUpdating = True
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Squirrel70Author Commented:
Hi Albert,
It worked perfectly!!!!! Thank you very much! I greatly appreciate all your help! My boss will be very happy now!  

Larry
0
Squirrel70Author Commented:
Thanks again Albert. You are the best!
0
ahammarCommented:
Your welcome Larry.  Thank you for the points and the grade!  I'm glad it worked out good and I hope it's useful for a long time...

:-)
Albert
0
Squirrel70Author Commented:
Hi Albert,

I did find one minor bug. When I add names to the last column and then run the macro it works fine but then if I add more names again right after that it runs fine but deletes one of the pictures. What would cause this? I attached the file so you can test it.

Add 2 names in column D (D1 & D2) and then fire the code. Then after that enter a name in cell D3 and try to fire it again. Put names in those three cells that need to be sorted into the existing cells. When you fire the code the second time it deletes one of the pictures.

Let me know what you find.
Employee-Composite-2008-BC-Rev1.xls
0
ahammarCommented:
I've tried to duplicate your problem, but I cannot...
Are you selecting all the cells before you run the macro...You have to select all the cells, and A1 must be included....The macro always starts the sorted list in Cell A1, no matter which cells you had selected to sort, so if you don't select them all, the ones that are in A1 on over to however many columns you had selected would be overwritten...that might be where your pictures are going...
When this happens, does the name and picture dissappear, or just the picture?

:-)
Albert
0
ahammarCommented:
Ps...when I say select all the cells, I mean all the cells with names...from A1 to the last cell with a name...

:-)
Albert
0
Squirrel70Author Commented:
I'm selecting all the cells from A1 to D3. The first time I ran it I put names in D1 & D2 and left D3 blank. I selected all the cells from A1 to D3 and ran the macro and it worked. But then I put a name in D3 and ran it again and that's when the picture for Diane disappeared. The names all sorted properly but it deleted that picture. Her name is still there though.

Here's what I did.

Added names to D1 & D2.
Selected cells A1 to D3
Ran macro
Successful

Then added a name to cell D3
Selected Cells A1 to D3
Ran macro
Successful but the picture for Diane was deleted but her name did not.

I just tested it again but this time I just did the first part and added names to D1 & D2. And it ran fine. Then I closed the file and re-opened it and entered a name into D3 and ran it and this time it ran fine. Does this makes sense why it would work after closing and opening the file?
0
ahammarCommented:
ok...2 questions:

Added names to D1 & D2.
Selected cells A1 to D3
Ran macro
Successful
Q 1.  What were the exact names you added?

Then added a name to cell D3
Selected Cells A1 to D3
Ran macro
Successful but the picture for Diane was deleted but her name did not.
Q 2.  What was the exact name you added?

So I can use the exact same name and get the same sorting results..

:-)
Albert
0
ahammarCommented:
Also...throw this macro at the top or bottom of your module (or a new module), and run it after this happens...
It should select the cell where the picture is at..
Let me know what cell it selects, even if the picture is not there..

I am assuming that Dianes picture is named the same as in the file you last uploaded and that you did not change it...

Maybe you should run this macro before the picture disappears to make sure that it does select the cell...

:-)
Albert

Sub FindPicture()
    ActiveSheet.Shapes("Picture 3").TopLeftCell.Select
End Sub

Open in new window

0
Squirrel70Author Commented:
Q1. In D1 I put the name "Karn, Tom". In D2 I put the name "Law, Donna"
Q2. In D3 I put the name "Greene, Kelvin".

I tested your macro to find the picture after I ran the 2 function tests I posted earlier and it's located in cell IV13. That's odd huh?

You are correct, I did not change the name of Diane's picture.
0
ahammarCommented:
Ok...it's a glitch with 2007...I was able to duplicate it with 2007, but not 2003...
I just changed the sorting column to IU and it works fine...

Here is the new file

:-)
Albert


Employee-Composite-2008-BC-Rev1.xls
0
Squirrel70Author Commented:
Back in business! What kind of glitch would cause that in 2007? Does it have something to with the number of columns in the two versions?
0
ahammarCommented:
I don't know for sure.  Both versions have the same number of columns.  It had something to do with the cell in the last column not recognizing that there was a picture in it.  Probably because of some kind of mis-syncronization between the outside border of the last column, and the right edge of the picture...I did some experimenting and noticed that if I moved the cell (when the picture stayed in column IV), the picture did not move with it, but then if I moved the picture just slightly over to the left, then it would move with it...so it's a glitch that hopefully will be fixed in some update down the road...

:-)
Albert
0
Squirrel70Author Commented:
Thanks Albert. All is well again. Thanks again for all your help.

Take Care
Larry
0
Squirrel70Author Commented:
Hi Albert,
Me again! :)
I'm running into a small problem. If I run the macro more than once it takes the picture "Pasquale Folgore" and puts it on top of the picture of "Diane Ferrera". I've attached the file for you to test. Highlight all the cells from A1 to G12 and click the macro button once and then click it again and you'll see what happens. And if I add a new picture and run the macro it does the same thing. But if I close the file and reopen it and insert the picture and run it then it's fine. But then if I was to add another picture after that and ran it again it would do the same thing. Any ideas?
Employee-Composite-2008-BC-Rev2.xls
0
ahammarCommented:
Ok...it must be a glitch with Excel 2007 because it works fine with 2003, but when I use 2007, I get the same results that you do...I'm guessing that it has something to do with Excel 2007 not being able to resize the picture to the size of the cell when it gets moved to column IU and doesn't calibrate something properly until it gets closed or something...I don't know...but here is a workaround if it will work for you.  All I did was make the entire workbook's cells all the same size as the ones you are using, and it seems to work fine now since the pictures can fit inside the cell they are suppose to stay with.  Apparently, 2003 does a better job of moving and sizing pictures with cells....
If this is a problem, then let me know and I will see if I can come up with something...


Employee-Composite-2008-BC-Rev2.xls
0
ahammarCommented:
Or if you want...you can try this...I added some code to put the picture back with the cell it was orinally with, so this should do away with those glitches...

Ps...I need to make a correction on something that I told you awhile back...Excel 2007 does have a lot more columns then 2003...just wanted to clear myself up on that...

:-)
Albert

Employee-Composite-2008-BC-Rev3.xls
0
ahammarCommented:
Good morning Larry,

I thought of a problem with my last upload that could potentially cause it to not work right, so I revised it again...I think this takes care of everything.  There is also an added macro I just threw in to name all the cells that are selected to the name of whatever is in the cell.  I see you named a couple cells, so I just threw that in to name all the cells in the range you have selected.  It is completely seperate from the other macro and will need to be run seperately if you choose to use it.  Just select the cells you want to name and run it...
Anyway, this is probably the most dependable one...although the one where I changed all the cell sizes is probably a good one too...but this one actually puts the picture where it should go using code, and does not rely on Excel to put it where it should...so...take your pick...:-)

ps...this is the exact same file you uploaded last with the macro in it, but it has not been run yet on this workbook...


:-)
Albert
Employee-Composite-2008-BC-Rev4.xls
0
Squirrel70Author Commented:
Hi Albert,

Thanks again for your continued support and help. I greatly appreciate it as always! I went with Rev 5 since that had all the pieces in it.

Thanks!
Larry
0
Squirrel70Author Commented:
Hi Albert,

Quick question....say I wanted to change the sort function from the persons name to their hire date, would I have to change anything in your VBA code to do this?
0
ahammarCommented:
If you replace the name that is in the cell, with a date instead, it should still work fine...You would have to see if there are any problems, but I can't think of any...I tried it a little bit and it worked ok...but I didnt' put through any stressfull testing...

:-)
Albert
0
Squirrel70Author Commented:
Hi Albert,

I actually just got done trying it and it does work to a degree. If I use the format "01/01/2008" it will only sort it by the month and not the day and year. Should I change the format or is there something you can switch in the code to have it recognize the entire date?
0
ahammarCommented:
That's strange...you can try this and see if it fixes the problem...

Replace the SortAllRangeData procedure with this SortAllRangeData procedure...

Be sure you replace only the 1 procedure, and not anything else in the module....

See if that fixes it...

:-)
Albert

Sub SortAllRangeData()
Dim CCnt As Integer
Dim rCnt As Long
Dim LastCcnt As Long
Dim s As Shape
Dim r As Range
 
 
Application.ScreenUpdating = False
NameAll
 
 
Columns("IU:IU").Delete
 
   ' Place column header for temporary sort area.
   Range("IU1").Value = "Numbers"
   
   ' Move numbers to temporary sort location.
   For Each cell In Selection
      If cell.Value = "" Then cell.Value = "zzzzzzz"
      cell.Cut Destination:=Range("IU65536").End(xlUp).Offset(1, 0)
   Next cell
   
 
   
    Range("IU1", Range("IU1").End(xlDown)).NumberFormat = "General"
   
        ' Sort numbers in descending order.
        Range("IU1", Range("IU1").End(xlDown)).Sort Key1:=Range("IU2"), _
        Order1:=xlDescending, Header:=xlYes, _
             OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
    Range("IU1", Range("IU1").End(xlDown)).NumberFormat = "mm/dd/yy;@"
   
 For CCnt = 1 To Selection.Columns.Count
    For rCnt = 1 To Selection.Rows.Count
        Range("IU65536").End(xlUp).Cut Cells(rCnt, CCnt)
    Next rCnt
Next CCnt
 
   For Each cell In Selection
      If cell.Value = "zzzzzzz" Then cell.Value = ""
   Next cell
 
PlacePictures
 
For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, Selection) Is Nothing Then
        Set r = s.TopLeftCell
        s.Left = r.Left + ((r.Width - s.Width) / 2)
        s.Top = r.Top + ((r.Height - s.Height) / 2)
    End If
Next s
 
UndoName
Application.ScreenUpdating = True
End Sub

Open in new window

0
Squirrel70Author Commented:
Hi Albert,

I'm now getting an error message: Run-Time Error 1004, Delete Method of Range Class Failed

And it highlights this code: Columns("IU:IU").Delete
0
Squirrel70Author Commented:
Actually the reason I got that code was because I had the worksheet protected. I remove the protection and it didn't error out. But It didn't sort it by the entire date. It's still sorting it by just the month.
0
ahammarCommented:
And you have nothing in the cell except the date...right?

0
ahammarCommented:
Oh...I think I know what the problem might be.....let me get back to you in a few minutes..

:-)
Albert
0
ahammarCommented:
Ok...I think I know what the problem was...my own question that I asked made me think of it...
Just before the cells get moved to the sorting column (IU)...All the pictures in the selection get renamed to the cell address they are in...and all the cell's values also get that same address appended to the end of whatever value is in the cell...that's so the pictures can be matched back up again with whatever cell they were originally with before the sort....then the address got removed from the cells value to leave the original value in the cell after they got put back into the area you had selected...
So since it was sorting with that value appended to the end of the date, Excel didn't see it as a date, but just a number with characters at the end..

Anyway...I fixed that problem by moving the appended address to the column to the left (after they got moved to the sorting column)...sort both columns, then append them back again...You should still be able to use names or dates.

IMPORTANT:
I also added a line of code near the beginning of this code to unprotect your sheet, then a line near the end to protect it again so you will be able to protect your sheet and the code will still work...You will need to change the password in the code to what you want it to be...or make the password be empty if you do not want one, or just get rid of those lines altogether if you don't want them...

NOTE:
I am also uploading the new file for my use in case I have to get it again because I won't keep a copy of it...I'm sure you are way to far along in yours to want to use this one, but it's mainly for my use in case I ever need to look at it to help you out...

Here is the new code...replace just the same procedure that you did before with this one...

Sub SortAllRangeData()
Dim CCnt As Integer
Dim rCnt As Long
Dim LastCcnt As Long
Dim s As Shape
Dim r As Range
Dim r2 As Range
 
'Unprotect the sheet
Sheets("BC").Unprotect Password:="YourPassword"
 
 
Application.ScreenUpdating = False
NameAll
 
 
Columns("IT:IU").Delete
 
   ' Place column header for temporary sort area.
   Range("IU1").Value = "Numbers"
   Range("IT1").Value = "CellAddress"
   
   ' Move numbers to temporary sort location.
   For Each cell In Selection
      If cell.Value = "" Then cell.Value = "zzzzzzz"
      cell.Cut Destination:=Range("IU65536").End(xlUp).Offset(1, 0)
   Next cell
   
 
'Move the appended cell address to the previous columns
Set r2 = Range("IU1")
    Do Until r2.Value = ""
        If InStr(r2.Value, "|") > 0 Then
            r2.Offset(0, -1).Value = Trim(Split(r2.Value, "|")(1))
            r2.Value = Trim(Split(r2.Value, "|")(0))
        End If
        Set r2 = r2.Offset(1, 0)
    Loop
    
   
        ' Sort numbers in descending order.
        Range("IT1", Range("IU1").End(xlDown)).Sort Key1:=Range("IU2"), _
        Order1:=xlDescending, Header:=xlYes, _
             OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
   
'Move the cell address back to the original cells after sorting
Set r2 = Range("IU2")
    Do Until r2.Value = ""
        If r2.Offset(0, -1).Value <> "" Then
            r2.Value = r2.Value & "|" & r2.Offset(0, -1).Value
        End If
        Set r2 = r2.Offset(1, 0)
    Loop
 
 
'Move sorted cells back to area that was selected
 For CCnt = 1 To Selection.Columns.Count
    For rCnt = 1 To Selection.Rows.Count
        Range("IU65536").End(xlUp).Cut Cells(rCnt, CCnt)
    Next rCnt
Next CCnt
 
   For Each cell In Selection
      If cell.Value = "zzzzzzz" Then cell.Value = ""
   Next cell
 
PlacePictures
 
 
 
For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, Selection) Is Nothing Then
        Set r = s.TopLeftCell
        s.Left = r.Left + ((r.Width - s.Width) / 2)
        s.Top = r.Top + ((r.Height - s.Height) / 2)
    End If
Next s
 
UndoName
 
'Protect the sheet
Sheets("BC").Protect Password:="YourPassword"
 
 
Application.ScreenUpdating = True
 
End Sub

Open in new window

Employee-Composite-2008-BC-Rev6.xls
0
Squirrel70Author Commented:
Perfect! Working like a charm. I think that should cover everything. Hopefully my boss won't ask me to modify it anymore. I think I've done exactly what he wants. Thanks again Albert!!!!!!
0
Squirrel70Author Commented:
Hi Albert,

It's the pest again! :)
How easy would it be to switch the sorting from top to bottom to left to right? They want to know if I can have it sort across the rows and then start the sort in the next row from left to right, etc.
0
ahammarCommented:
Find lines 58 - 62 (5 lines) in the code above and change it to this:

I think that will do it, but you'll have to test it to make sure..

:-)
Albert



For rCnt = 1 To Selection.Rows.Count
    For CCnt = 1 To Selection.Columns.Count
        Range("IU65536").End(xlUp).Cut Cells(rCnt, CCnt)
    Next CCnt
Next rCnt

Open in new window

0
Squirrel70Author Commented:
That looks the same as the current code in lines 58 - 62. Did you mean to do that? ;-)
0
Squirrel70Author Commented:
Nevermind. It is different. It looked the same when I first looked at it. My bad!
It works perfectly. Another job well done!! Thank you again!
0
ahammarCommented:
Ya...you have to look pretty close or it looks the same...
You're very welcome and I'm glad it worked!

Also...this probably doesn't work for your situataion, but in case it does...
here is a slight modification that allows you to choose to sort horizontally or verticaly, but you have to click 1 of the options each time you run the macro, but you also have an option to cancel, but you can use it if you want...
This is still just the 1 procedure again...

:-)
Albert

Sub SortAllRangeData()
Dim CCnt As Integer
Dim rCnt As Long
Dim LastCcnt As Long
Dim s As Shape
Dim r As Range
Dim r2 As Range
Dim sStyle As Integer
 
sStyle = MsgBox("Do you want to sort horizontally?" & vbNewLine & "Click Yes for horizontal sort, or No for vertical sort", vbYesNoCancel)
If sStyle = vbCancel Then Exit Sub
 
 
'Unprotect the sheet
Sheets("BC").Unprotect Password:="YourPassword"
 
 
Application.ScreenUpdating = False
NameAll
 
 
Columns("IT:IU").Delete
 
   ' Place column header for temporary sort area.
   Range("IU1").Value = "Numbers"
   Range("IT1").Value = "CellAddress"
   
   ' Move numbers to temporary sort location.
   For Each cell In Selection
      If cell.Value = "" Then cell.Value = "zzzzzzz"
      cell.Cut Destination:=Range("IU65536").End(xlUp).Offset(1, 0)
   Next cell
   
 
'Move the appended cell address to the previous columns
Set r2 = Range("IU1")
    Do Until r2.Value = ""
        If InStr(r2.Value, "|") > 0 Then
            r2.Offset(0, -1).Value = Trim(Split(r2.Value, "|")(1))
            r2.Value = Trim(Split(r2.Value, "|")(0))
        End If
        Set r2 = r2.Offset(1, 0)
    Loop
    
   
        ' Sort numbers in descending order.
        Range("IT1", Range("IU1").End(xlDown)).Sort Key1:=Range("IU2"), _
        Order1:=xlDescending, Header:=xlYes, _
             OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
   
'Move the cell address back to the original cells after sorting
Set r2 = Range("IU2")
    Do Until r2.Value = ""
        If r2.Offset(0, -1).Value <> "" Then
            r2.Value = r2.Value & "|" & r2.Offset(0, -1).Value
        End If
        Set r2 = r2.Offset(1, 0)
    Loop
 
 
'Move sorted cells back to area that was selected
If sStyle = vbNo Then
    For CCnt = 1 To Selection.Columns.Count
        For rCnt = 1 To Selection.Rows.Count
            Range("IU65536").End(xlUp).Cut Cells(rCnt, CCnt)
        Next rCnt
    Next CCnt
Else
    For rCnt = 1 To Selection.Rows.Count
        For CCnt = 1 To Selection.Columns.Count
            Range("IU65536").End(xlUp).Cut Cells(rCnt, CCnt)
        Next CCnt
    Next rCnt
End If
 
   For Each cell In Selection
      If cell.Value = "zzzzzzz" Then cell.Value = ""
   Next cell
 
PlacePictures
 
 
 
For Each s In ActiveSheet.Shapes
    If Not Intersect(s.TopLeftCell, Selection) Is Nothing Then
        Set r = s.TopLeftCell
        s.Left = r.Left + ((r.Width - s.Width) / 2)
        s.Top = r.Top + ((r.Height - s.Height) / 2)
    End If
Next s
 
UndoName
 
'Protect the sheet
Sheets("BC").Protect Password:="YourPassword"
 
 
Application.ScreenUpdating = True
 
End Sub

Open in new window

0
Squirrel70Author Commented:
I like that! Thank you very much. I'll let my boss know so that when he changes his mind again he'll have the option available to him.
I wish I could learn this stuff but it just seems so hard to understand at times.

0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Spreadsheets

From novice to tech pro — start learning today.