Macro - Split into Multiple Worksheets

Hi,

first post, hope I don't make too many gaffes

I found this macro that does what I want but I need to change it slightly.

It splits a big list onto different worksheets based on a category in column A.

I've tried but I can't work out how to make it look in a different column. Here's the code I have now, I already improved it to work with long category names with spaces in them.

Sub SplitIntoWorksheets() 
Dim rRange As Range, rCell As Range 
Dim wSheet As Worksheet 
Dim wSheetStart As Worksheet 
Dim strText As String 
Dim strTitle As String

* * Set  wSheetStart = ActiveSheet 
*  * wSheetStart.AutoFilterMode = False 
* * 'Set a range variable to the correct item  column 
* * Set rRange =  Range("A1", Range("A65536").End(xlUp)) 
* * 

* * * * 'Delete any sheet called  "UniqueList" 
* * *  * 'Turn off run time errors & delete alert 
* * * * On Error Resume Next  
* * * *  Application.DisplayAlerts = False 
* * * *  Worksheets("UniqueList").Delete 
* * * * 'Add a sheet called  "UniqueList" 

* * *  * Worksheets.Add().Name = "UniqueList" 
* * * * 
* * * * * *'Filter the Set range  so only a unique list is created 

* * * * * * With  Worksheets("UniqueList") 

*  * * * * * * * rRange.AdvancedFilter  xlFilterCopy, , Worksheets("UniqueList").Range("A1"), True  
* * * * * *  * * * 
* *  * * * * * * *'Set a range variable to the  unique list, less the heading. 

* * * * * * * *  *Set rRange = .Range("A2", .Range("A65536").End(xlUp))  

* * * * * *  End With 
* * *  * * * 

* *  * * * * On Error Resume Next 

* * * * * * With  wSheetStart 

* * *  * * * * * For Each rCell In rRange  

* * * * * *  * * * strText = rCell 
* * * * * * * * *  
* * * * *  * * * * strTitle = Replace(strText, " ", "_")
* * * * * * * * *  
* * * * *  * * * * strTitle = Left(strTitle, 31)

* * * * * *  * * *.Range("A1").AutoFilter 1, strText 

* * * * * * * *  * * Worksheets(strTitle).Delete

* * * * * *  * * * * 'Add a sheet named as content of rCell  

* * * * * *  * * * * Worksheets.Add().Name = strTitle

* * * *  * * * * * * 'Copy the visible filtered range  _ 

* * * *  * * * * * * '(default of Copy Method) and leave  hidden rows 

* * *  * * * * * * * .UsedRange.Copy  Destination:=ActiveSheet.Range("A1") 

* * * * * * * * *  * ActiveSheet.Cells.Columns.AutoFit 

* * * * * * * * Next  rCell 

* * * *  * * End With 
*  * * * * * 

* * * * With wSheetStart  

* * * * * *  .AutoFilterMode = False 

*  * * * * * .Activate 

* * * * End With 
 * * * 

* * * * On Error GoTo 0  

* * * *  Application.DisplayAlerts = True 

End Sub

Thanks Jerry, I'll be trying that on Monday when i get back to the office.

Any chance of commenting your code so I can understand what it's doing?

Thanks again.
John.

Just tested that at work and it's spot on...

thanks again Jerry, that's gonna save me hours!

I have just tried it out and it is going to make my life a lot easier Jerry... Thanks a lot

Brilliant, it just works perfect for me too. Thanks Jerry.

'Samall addition to select the column to split , no need of hard coding column number.
enter column # through input box.
'Enter the column # here to evaluate, column A = 1
fCol = InputBox("Split column number")

I was looking for something like this and found many macros, but this one works the best. Thanks a lot!

This was VERY HELPFUL, THANK YOU!!!!