VBA: Split data into multiple worksheets based on column

[waxsublime]

I'm trying to get this code I found (from How to split data into multiple worksheets based on column in Excel?) to work, but it's giving me an error.

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 4
    Set ws = Sheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:I1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
End Sub

Any ideas on how to fix this?

Thanks!

 

[ArmyGuy45]

Bumping this thread.

I am looking to add to the code here and was wondering if you guys could help.

Sub ClientAllocate()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Application.ScreenUpdating = False
vcol = 4
Set ws = Sheets("1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:D1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
    Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
End Sub

I would like the make the sheets that are created placed in alphabetical order AND I would like to make each one of those sheets alphabetical by a specific column of my choosing. Can you guys help me with that?

 

[DocAElstein]

Bumping this thread.

I am looking to add to the code here..................
I would like the make the sheets that are created placed in alphabetical order AND I would like to make each one of those sheets alphabetical by a specific column of my choosing. Can you guys help me with that?

Hi Army Guy..
. Welcome to the Board
. I was in this Thread a bit.
. I guess if no one picks the Thread up in a day or so and you are still interested in a solution then I will probably have a go…

. But anyways it would help a lot if you read the Forum FAQ. Posting guidelines, rules etc. and learn to use the Forum Tools shown in my signature below.

. ……………..

. Failing that drop a file off, for example using this free thing:
Box Net,
https://www.box.net

. Remember to select Share after uploading and give us the link they provide.

. Put a small but representative set of test data in a sheet and importantly, show some new sheets and put in the data exactly as it should look like after running any code variation anyone gives you based on the actual test data you use.

. In plain English show us “Pictorialally” as it were exactly wot you want..

Alan.

 

[ArmyGuy45]

Thank you for the quick reply.

I am looking to take data like in this example:

Master List

First Name	Last Name	Other Stuff	Client
Jim	Brown	1	A
Tim	White	2	C
Boy	Boy	3	B
Girl	Girl	4	A
Jane	Smith	5	A
John	Doe	6	C
Brian	Good	7	B
Amy	Ports	8	B
Nathan	Fill	9	C

<tbody>
</tbody>

And convert it into this:

Sheet A

First Name	Last Name	Other Stuff	Client
Jim	Brown	1	A
Girl	Girl	4	A
Jane	Smith	5	A

<tbody>
</tbody>

Sheet B

First Name	Last Name	Other Stuff	Client
Boy	Boy	3	B
Brian	Good	7	B
Amy	Ports	8	B
Sheet C
First Name	Last Name	Other Stuff	Client
John	Doe	6	C
Nathan	Fill	9	C
Tim	White	2	C

Dunno why that table is so big but hopefully this gives you an idea of what I am looking for.

I need each sheet tab to be in alphabetical order and "Last Name" column in alphabetical order per sheet.

 

[DocAElstein]

........

I am looking to take data like in this example:........

I need each sheet tab to be in alphabetical order and "Last Name" column in alphabetical order per sheet.

Hi Army Guy,
. I have an initial code for you which appears to work well with your sample data giving all the results as you want them.
. I am not too happy with it as a final solution. Mainly as some Sorting stuff necessary for your wonted Alphabetical ordering was new to me. So I sort of “cheated” and got those code bits from a macro recording. So there is definitely a more efficient way to do those bits. I shall take a look at those aspects when I get the time over the next day or so and try to do it a bit more professionally if no one else looks in and improves the code for you.
. My start point was my codes from my post #40, which was the more correct way of doing the code version that you had picked out and posted in your post #41
. I do not know your level of ability with macros and VBA. So I will post the code that appears to work for now. Maybe it will give you something to start playing with in the meantime.
. If no one comes in with anything better I guess we will be in touch again through this Thread.
. Let me know anyway how you get on if you make any progress in using it.

Alan



Code:

[color=darkblue]Option[/color] [color=darkblue]Explicit[/color]
 
 
[color=darkblue]Sub[/color] ClientAllocate_AlanJan2015()
 
Application.ScreenUpdating = [color=darkblue]False[/color] [color=green]'Not necerssary but speeds things up a bit, by turning screen updating off. Good to edit out for Debuging[/color]
[color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]GoTo[/color] TheEnd [color=green]'If anything goes wrong go to the End instead of crashing. Useful to Edit out for Debuging[/color]
[color=darkblue]Dim[/color] wks1 [color=darkblue]As[/color] Worksheet: [color=darkblue]Set[/color] wks1 = ThisWorkbook.Worksheets("Master List") [color=green]'set sheet name - Give abbreviation for First sheet in this all Properties and Methods of Object Worksheet[/color]
 
        [color=green]'Start Bit to  Delete Sheets / Tabs------------[/color]
        Application.DisplayAlerts = [color=darkblue]False[/color] [color=green]'Prevents being asked everytime if you really want to delete the Workbook[/color]
        [color=darkblue]Dim[/color] ws [color=darkblue]As[/color] Worksheet [color=green]'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
        [color=darkblue]For[/color] [color=darkblue]Each[/color] ws [color=darkblue]In[/color] ActiveWorkbook.Worksheets [color=green]'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
            [color=darkblue]If[/color] ws.Name <> wks1.Name [color=darkblue]Then[/color] [color=green]'Name property here returns name without .xlsm bit on end[/color]
            ws.Delete
            [color=darkblue]Else[/color] [color=green]'Presumably then the worksheet name is That of the first sheet so[/color]
            [color=green]' do nothing (Don't delete it!)[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]Next[/color] ws
        Application.DisplayAlerts = [color=darkblue]True[/color] [color=green]'Turn it back on[/color]
        [color=green]'End Bit to delete any Sheets / Tabs------------[/color]
 
[color=green]'Some variables used in various places[/color]
[color=darkblue]Dim[/color] vLkUpc [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] vLkUpc = 4 [color=green]'set column number 'Column where search criteria for filtering is. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) -Most smaller numbers, Byte, Integer, Single are converted in computer to long so no advantage of Dim to smaller Type here)[/color]
[color=darkblue]Dim[/color] rws [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Bound variable Row count used in looping[/color]
[color=darkblue]Dim[/color] lr [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lr = wks1.Cells.Find(What:="*", after:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=green]'Get last Row with entry anywhere for Sheet1. Method: You start at first cell then go backwards (which effectively starts at end of sheet), sercching for anything ( = * ) by rows, then get the row number. This allows for different excel versions with different available Row numbers) Just a different method here for fun- finds last row in sheet rather than row for last entry in particular cell[/color]
[color=darkblue]Dim[/color] lshtc [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lshtc = wks1.Columns.Count [color=green]'Number of Columns in sheet[/color]
[color=darkblue]Dim[/color] lc [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lc = wks1.Cells(1, lshtc).End(xlToLeft).Column [color=green]'Last column with entry in heading in Sheet 1. Found by starting at last cell in row 1, then going backwards (ToLeft) until something is found, with .End returning a range from which the column property can be used to get the column number[/color]
[color=green]'--------------------------------------[/color]
 
    [color=green]'make an Array for Unique Search values, using a Tempory column[/color]
    [color=darkblue]Let[/color] wks1.Cells(1, lshtc) = "Unique" [color=green]'The last Column inn the sheet is used. (This has an advantage of not  interfering with our Method for getting lc). hee just for fun we give the array, that is to say the tempory column, a heading[/color]
        [color=darkblue]For[/color] rws = 2 [color=darkblue]To[/color] lr [color=darkblue]Step[/color] 1 [color=green]'Going down all rows  from just after heading in First sheet[/color]
        [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]Resume[/color] [color=darkblue]Next[/color] [color=green]'Necersary to ensure the looping goes on if the match cannot be determined, as below we have a look Up Array with empty cells[/color]
            [color=darkblue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = 0 [color=darkblue]Then[/color] [color=green]'provided something is there, we check to see if that value is already in our vLook Up Array by looking to see for a match. If it is not there then.....[/color]
            wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc) [color=green]'.....Put  it there[/color]
            [color=darkblue]Else[/color] [color=green]'Else do nothing[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]Next[/color] rws
    [color=darkblue]Dim[/color] lrUnique [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lrUnique = wks1.Cells(Rows.Count, lshtc).End(xlUp).Row [color=green]'Determine last row of tempory column[/color]
      
       [color=green]'Simple A-B order sorting for temüory Unique Column got by "cheating" with macro recorder-[/color]
       wks1.Sort.SortFields.Add Key:=Cells(1, lshtc), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortText[color=darkblue]As[/color]Numbers
       [color=darkblue]With[/color] wks1.Sort
        .SetRange wks1.Range(wks1.Cells(2, lshtc), wks1.Cells(lrUnique, lshtc))
        .Header = xlNo
        .MatchCase = [color=darkblue]False[/color]
        .Orientation = xlTop[color=darkblue]To[/color]Bottom
        .SortMethod = xlPinYin
        .Apply
       [color=darkblue]End[/color] [color=darkblue]With[/color] [color=green]'---------------------------------------------------------------------------------[/color]
    wks1.Cells(1, 1).Select [color=green]'Just to quickly take us back as the Sorting of uniques left us at end of sheet!![/color]
    Dim myarr() [color=darkblue]As[/color] [color=darkblue]Variant[/color] [color=green]'Array for Unique search criteria. Important to get this [color=darkblue]Dim[/color]ensioning right. Variant must be used as below  initially an object is seen...>>  http://www.excelforum.com/excel-new-users-basics/1058406-range-dimensioning-range-and-value-referencing-and-referring-to-arrays.html[/color]
    [color=darkblue]Let[/color] myarr() = Application.WorksheetFunction.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants, xlTextValues).Value) [color=green]'just a complicated but nice one-liner way of getting just the values and no empty cells in the Array. XlcellTypeConstants just gives constants, the second argument is the type. Here Strings are there as the heading made sure of that - here excel guessed based on that due to the heading string "Unique".. This could be an untypical case where that second argument could be left out. Transpose is just to get the Array as A Row of Columns which we need rather than a Column of rows as is in the tempory Column.[/color]
    wks1.Columns(lshtc).Delete [color=green]'Delete the tempory Column (Delete is usually better than Clear.. >>  http://www.mrexcel.com/forum/excel-questions/787428-clear-delete-shift-%3Dxlup-let-y-%3D-y-%96-1-usedrange-rows-count-anomale.html[/color]
    [color=green]'End of making an Array---------[/color]
 
    [color=green]'Make a New worksheet with the name of the Unique search criteria, and in the same loop.....--->>-[/color]
     Dim lrNewsheet As [color=darkblue]Long[/color] [color=green]'Variable for Lastr Row in New Worksheet[/color]
        [color=darkblue]For[/color] rws = 2 To [color=darkblue]UBound[/color](myarr) [color=green]'For each unique value in the Array[/color]
        wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter field:=vLkUpc, Criteria1:="" & myarr(rws) & "" [color=green]'This blends out everything except  where rows meet our search citeria[/color]
            [color=darkblue]If[/color] [color=darkblue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then [color=green]'Check to see if the sheet is there by seeing if the reference to cell A1 in that sheet doesn#t exist. If it is true that it does not exist, then[/color]
           
            Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "" & myarr(rws) & "" [color=green]'Make it as that after the last sheet[/color]
            [color=darkblue]Else[/color]
            Worksheets("" & myarr(rws) & "").Move after:=Worksheets(Worksheets.Count) [color=green]'Otherwise If the sheet is there it could be anywhere so we put it after last sheet[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
   
        [color=green]'.......->>---...Copy Entire row that is visible (Not blended out) to the current sheet in loop[/color]
        wks1.Range("A" & 1 & ":A" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy [color=green]'Copy just wot is visible after filtering[/color]
        Worksheets("" & myarr(rws) & "").Range("A1").PasteSpecial Paste:=xlPasteFormulas [color=green]'Being very Explicit here with an extra line enabling us to Paste Special with arguments to make sure the correct version from Clipboard is copied[/color]
        Worksheets("" & myarr(rws) & "").Columns.AutoFit [color=green]'Just tidy up a bit[/color]
        [color=darkblue]Let[/color] lrNewsheet = Worksheets("" & myarr(rws) & "").Cells(Rows.Count, 1).End(xlUp).Row [color=green]'Determine last Row in New Sheet[/color]
 
        [color=green]'.. Same Again!! -Simple A-B order sorting for temüory Unique Column got by "cheating" with macro recorder-[/color]
            Worksheets("" & myarr(rws) & "").Range("A2:D" & lrNewsheet & "").Select
            Worksheets("" & myarr(rws) & "").Sort.SortFields.Clear
            Worksheets("" & myarr(rws) & "").Sort.SortFields.Add Key:=Worksheets("" & myarr(rws) & "").Range("B2:B" & lrNewsheet & ""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            [color=darkblue]With[/color] Worksheets("" & myarr(rws) & "").Sort
                .SetRange Worksheets("" & myarr(rws) & "").Range("A2:D" & lrNewsheet & "")
                .Header = xlGuess
                .MatchCase = [color=darkblue]False[/color]
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            [color=darkblue]End[/color] [color=darkblue]With[/color] [color=green]'---------------------------------------------------------------------------------------------[/color]
       
        [color=darkblue]Next[/color] rws
    [color=green]'End making (if necerssary) new sheet and copying filtered rows to it and finally sorting by Second name[/color]
 
wks1.AutoFilterMode = [color=darkblue]False[/color] [color=green]'re - Blend in everything in sheet 1' Alternative  >>  wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter[/color]
wks1.Activate [color=green]'Activate that sheet 1 just to see it[/color]
 
TheEnd:
Application.ScreenUpdating = [color=darkblue]True[/color] [color=green]'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.[/color]
 
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'ClientAllocate_AlanJan2015[/color]

 

[ArmyGuy45]

Doc,

No need to bother! The code works great. I updated the file name to match my file and it worked beautifully. Thank you so much!!!

 

[DocAElstein]

Doc,

No need to bother! ......... I updated the file name to match my file and it worked ...Thank you ...

. OK!

. Thanks for the feedback.
. Cheers,
. Alan

P.s. I will probably tidy the code up anyways, and do a version with all the messy comments knocked off.
( - Mostly do that for my own benefit so I can remember for the next time it comes up. (Stumbled over an old book that explains sorting with example data coincidentally very similar to yours. So that’s nice. - I can understand and re-write that bit properly without relying on the “cheated bit” from the macro recording!) ..)

 

[ArmyGuy45]

Amazing Doc, I got another one for you. We export our AD user information into excel and was hoping there was a way to do the same separation like before. Break out the client name from the AD lines within the "Master List" to create other sheets that are in alphabetical order.

To give you an example of what my output looks like....

<tbody>
</tbody>

Column 1	Column 2	Column 3	Member Of	Column 5	Column 6
A	1	Z	CN=CLOUD_AllUsers@CLIENT NAME,OU=Groups,OU=CLIENT-NAME,OU=CLOUD,DC=cloud,DC=mycompany,DC=mynet;CN=CLIENT-NAME	AA	AA
A	1	Z	<colgroup><col width="712"></colgroup><tbody> CN=CLOUD_AllUsers@CLIENT NAME,OU=Groups,OU=CLIENT-NAME,OU=CLOUD,DC=cloud,DC=mycompany,DC=mynet;CN=CLIENT-NAME </tbody>	BB	BB

<tbody>
</tbody>

So in my forth column I have the "Member Of" information from the AD output. The name of my client appears after the "@" symbol and runs until the first ",". Is there a way to break out each of the client names into different sheets in alphabetical order and keeping that Member Of column in alphabetical order in each sheet?

 

[DocAElstein]

Hi Army Guy,

Amazing Doc, I got another one for you. .....

… hang on a mo..

Hi Army Guy,
. I have an initial code ................. not too happy with it as a final solution. Mainly as some Sorting stuff necessary for your wonted Alphabetical ordering was new to me. So I sort of “cheated” and got those code bits from a macro recording. So there is definitely a more efficient way to do those bits. I shall take a look at those .......and re-write that bit properly.....

… This threads quite popular so let me tidy up my bad doings first..

. After about 5 minutes of reading a book I saw how stupid my Macro recording Sorting Code Bit woz.
… Let me explain that for my benefit (if no-one else’s!)

. Doing wot you wonted is actually dead easy using the simplest VBA .sort Method. In fact you can sort again after the surname, for example, by first name if any surnames are the same. And you may once more sort by other stuff, for example by age, incase both surnames and first names are the same. The code is a dead easy one liner….
. Take an example like yours:

	A​	B​	C​	D​
1​	First Name​	Last Name​	Stinks?​	Other Age Stuff​
2​	Jim​	Brown​	N​	21​
3​	Tim​	White​	y​	33​
4​	Boy​	Brown​	N​	45​
5​	Girl​	Smith​	Y​	75​
6​	Jane​	Smith​	N​	36​
7​	John​	Doe​	N​	41​
8​	Brian​	Good​	Y​	53​
9​	Girl​	Smith​	N​	25​
10​	Willy​	Big​	Dunno​	25​

.. this code, (applied to that above table),:

[color=darkblue]Sub[/color] GetSortingRight()
[color=darkblue]Dim[/color] wksT [color=darkblue]As[/color] Worksheet: [color=darkblue]Set[/color] wksT = ThisWorkbook.Worksheets("SortOfTestie")
 
wksT.Range("A2:D10").Sort Key1:=wksT.Range("B2:B10"), Key2:=wksT.Range("A2:B10"), Key3:=wksT.Range("D2:D10")
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

… gives you this

	A​	B​	C​	D​
1​	First Name​	Last Name​	Stinks?​	Other Age Stuff​
2​	Willy​	Big​	Dunno​	25​
3​	Boy​	Brown​	N​	45​
4​	Jim​	Brown​	N​	21​
5​	John​	Doe​	N​	41​
6​	Brian​	Good​	Y​	53​
7​	Girl​	Smith​	N​	25​
8​	Girl​	Smith​	Y​	75​
9​	Jane​	Smith​	N​	36​
10​	Tim​	White​	y​	33​

.. simples!

. Up to XL 2007 you could sort for the same table up to 3 times (3 “keys” or “Fields” or “columns” or wotever). After XL 2007 you can do it for lots more. … BUT – the process is more complicated .. you ‘ave to add sort fields, do initializing, setting up etc. etc. -- as always the VBA macro recorder don’t know wot you want and so it did all that complicated stuff and added a few more arguments along the way which were unnecessary in your simple case..

. So anyways here is that better Code:

[color=darkblue]Sub[/color] ClientAllocate2_AlanJan2015()
 
Application.ScreenUpdating = [color=darkblue]False[/color] [color=green]'Not necerssary but speeds things up a bit, by turning screen updating off. Good to edit out for Debuging[/color]
[color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]GoTo[/color] TheEnd [color=green]'If anything goes wrong go to the End instead of crashing. Useful to Edit out for Debuging[/color]
[color=darkblue]Dim[/color] wks1 [color=darkblue]As[/color] Worksheet: [color=darkblue]Set[/color] wks1 = ThisWorkbook.Worksheets("Master List") [color=green]'set sheet name - Give abbreviation for First sheet in this all Properties and Methods of Object Worksheet[/color]
 
        [color=green]'Optional Start Bit to  Delete Sheets / Tabs------------[/color]
        Application.DisplayAlerts = [color=darkblue]False[/color] [color=green]'Prevents being asked everytime if you really want to delete the Workbook[/color]
        [color=darkblue]Dim[/color] ws [color=darkblue]As[/color] Worksheet [color=green]'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
        [color=darkblue]For[/color] [color=darkblue]Each[/color] ws [color=darkblue]In[/color] ActiveWorkbook.Worksheets [color=green]'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
            [color=darkblue]If[/color] ws.Name <> wks1.Name [color=darkblue]Then[/color] [color=green]'Name property here returns name without .xlsm bit on end[/color]
            ws.Delete
            [color=darkblue]Else[/color] [color=green]'Presumably then the worksheet name is That of the first sheet so[/color]
            [color=green]' do nothing (Don't delete it!)[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]Next[/color] ws
        Application.DisplayAlerts = [color=darkblue]True[/color] [color=green]'Turn it back on[/color]
        [color=green]'End Bit to delete any Sheets / Tabs------------[/color]
 
[color=green]'Some variables used in various places[/color]
[color=darkblue]Dim[/color] vLkUpc [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] vLkUpc = 4 [color=green]'set column number 'Column where search criteria for filtering is. '( Long is a Big whole Number limit (-2,147,483,648 to 2,147,483,647) -Most smaller numbers, Byte, Integer, Single are converted in computer to long so no advantage of Dim to smaller Type here)[/color]
[color=darkblue]Dim[/color] rws [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Bound variable Row count used in looping[/color]
[color=darkblue]Dim[/color] lr [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lr = wks1.Cells.Find(What:="*", after:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=green]'Get last Row with entry anywhere for Sheet1. Method: You start at first cell then go backwards (which effectively starts at end of sheet), sercching for anything ( = * ) by rows, then get the row number. This allows for different excel versions with different available Row numbers) Just a different method here for fun- finds last row in sheet rather than row for last entry in particular cell[/color]
[color=darkblue]Dim[/color] lshtc [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lshtc = wks1.Columns.Count [color=green]'Number of Columns in sheet[/color]
[color=green]'                  Let lshtc = 7'Tempory Overide... alternative position - see ####  just below[/color]
[color=darkblue]Dim[/color] lc [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lc = wks1.Cells(1, lshtc).End(xlToLeft).Column [color=green]'Last column with entry in heading in Sheet 1. Found by starting at last cell in row 1, then going backwards (ToLeft) until something is found, with .End returning a range from which the column property can be used to get the column number[/color]
[color=green]'--------------------------------------[/color]
 
    [color=green]'make an Array for Unique Search values, using a Tempory column[/color]
                 [color=green]'Let lshtc = 7 'This is a tempory "overide when debiugging to get thntempory column in view####[/color]
    [color=darkblue]Let[/color] wks1.Cells(1, lshtc) = "Unique" [color=green]'The last Column in the sheet is normally used. (This has an advantage of not  interfering with our Method for getting lc). hee just for fun we give the array, that is to say the tempory column, a heading[/color]
        [color=darkblue]For[/color] rws = 2 [color=darkblue]To[/color] lr [color=darkblue]Step[/color] 1 [color=green]'Going down all rows  from just after heading in First sheet[/color]
        [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]Resume[/color] [color=darkblue]Next[/color] [color=green]'Necersary to ensure the looping goes on if the match cannot be determined, as below we have a look Up Array with empty cells[/color]
            [color=darkblue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = 0 [color=darkblue]Then[/color] [color=green]'provided something is there, we check to see if that value is already in our vLook Up Array by looking to see for a match. If it is not there then.....[/color]
            wks1.Cells(wks1.Rows.Count, lshtc).End(xlUp).Offset(1) = wks1.Cells(rws, vLkUpc) [color=green]'.....Put  it there[/color]
            [color=darkblue]Else[/color] [color=green]'Else do nothing[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]Next[/color] rws
   
            [color=green]'Option to sort Unique column. Cannot sort an array so have to do it in Spreadsheet - bit slow so only sort if you must[/color]
            [color=darkblue]Dim[/color] lrUnique [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] lrUnique = wks1.Cells(Rows.Count, lshtc).End(xlUp).Row [color=green]'Determine last row of tempory column[/color]
            wks1.Activate [color=green]'Necerssary for sorting to work I think[/color]
            wks1.Range(wks1.Cells(1, lshtc), wks1.Cells(lrUnique, lshtc)).Sort Key1:=wks1.Range(wks1.Cells(1, lshtc), wks1.Cells(lrUnique, lshtc)), order1:=xlAscending, Header:=xlYes [color=green]'Give Table as range to sort, and column with sorting parameter (Key1:=) (They are the same here..)[/color]
             [color=green]'---------------------------------------------------------------------------------------------------------------------[/color]
            wks1.Cells(1, 1).Select [color=green]'Just to quickly take us back as the Sorting of uniques left us at end of sheet!![/color]
    Dim myarr() [color=darkblue]As[/color] [color=darkblue]Variant[/color] [color=green]'Array for Unique search criteria. Important to get this [color=darkblue]Dim[/color]ensioning right. Variant must be used as below  initially an object is seen...>>  http://www.excelforum.com/excel-new-users-basics/1058406-range-dimensioning-range-and-value-referencing-and-referring-to-arrays.html[/color]
    [color=darkblue]Let[/color] myarr() = Application.WorksheetFunction.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants, xlTextValues).Value) [color=green]'just a complicated but nice one-liner way of getting just the values and no empty cells in the Array. XlcellTypeConstants just gives constants, the second argument is the type. Here Strings are there as the heading made sure of that - here excel guessed based on that due to the heading string "Unique".. This could be an untypical case where that second argument could be left out. Transpose is just to get the Array as A Row of Columns which we need rather than a Column of rows as is in the tempory Column.[/color]
    wks1.Columns(lshtc).Delete [color=green]'Delete the tempory Column (Delete is usually better than Clear.. >>  http://www.mrexcel.com/forum/excel-questions/787428-clear-delete-shift-%3Dxlup-let-y-%3D-y-%96-1-usedrange-rows-count-anomale.html[/color]
    [color=green]'End of making an Array---------[/color]
 
    [color=green]'Make a New worksheet with the name of the Unique search criteria, and in the same loop.....--->>-[/color]
     Dim lrNewsheet [color=darkblue]As[/color] [color=darkblue]Long[/color], lcNewsheet [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'Variable for Last Row and column in New Worksheet[/color]
        [color=darkblue]For[/color] rws = 2 [color=darkblue]To[/color] [color=darkblue]UBound[/color](myarr) [color=darkblue]Step[/color] 1 [color=green]'For each unique value in the Array[/color]
        wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter field:=vLkUpc, Criteria1:="" & myarr(rws) & "" [color=green]'This blends out everything except  where rows meet our search citeria[/color]
            [color=darkblue]If[/color] [color=darkblue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then [color=green]'Check to see if the sheet is there by seeing if the reference to cell A1 in that sheet doesn#t exist. If it is true that it does not exist, then[/color]
           
            Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "" & myarr(rws) & "" [color=green]'Make it as that after the last sheet[/color]
            [color=darkblue]Else[/color]
            Worksheets("" & myarr(rws) & "").Move after:=Worksheets(Worksheets.Count) [color=green]'Otherwise If the sheet is there it could be anywhere so we put it after last sheet[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
   
        [color=green]'.......->>---...Copy Entire row that is visible (Not blended out) to the current sheet in loop[/color]
        wks1.Range("A" & 1 & ":A" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy [color=green]'Copy just wot is visible after filtering[/color]
        Worksheets("" & myarr(rws) & "").Range("A1").PasteSpecial Paste:=xlPasteFormulas: Application.CutCopyMode = [color=darkblue]False[/color] [color=green]'Being very Explicit here with an extra line enabling us to Paste Special with arguments to make sure the correct version from Clipboard is copied (Last bit just stops screen flicker after a copy and paste)[/color]
        Worksheets("" & myarr(rws) & "").Columns.AutoFit [color=green]'Just tidy up a bit[/color]
        [color=darkblue]Let[/color] lrNewsheet = Worksheets("" & myarr(rws) & "").Cells(Rows.Count, 1).End(xlUp).Row [color=green]'Determine last Row in New Sheet[/color]
 
            [color=green]'Option to sort Range based on a column. Cannot sort an array so have to do it in Spreadsheet - bit slow so only sort if you must[/color]
            [color=darkblue]Let[/color] lcNewsheet = Worksheets("" & myarr(rws) & "").Cells(1, Columns.Count).End(xlToLeft).Column [color=green]'Determine last column of new sheet -.. go to last column in first row, come back to left untill hit a filled cell, then use .column property to get the column number[/color]
            Worksheets("" & myarr(rws) & "").Activate [color=green]'Necerssary for sorting to work I think[/color]
            Worksheets("" & myarr(rws) & "").Range(Worksheets("" & myarr(rws) & "").Cells(1, 1), Worksheets("" & myarr(rws) & "").Cells(lrNewsheet, lcNewsheet)).Sort Key1:=Worksheets("" & myarr(rws) & "").Range(Worksheets("" & myarr(rws) & "").Cells(1, 2), Worksheets("" & myarr(rws) & "").Cells(lrNewsheet, 2)), order1:=xlAscending, Header:=xlYes [color=green]'Give Table as range to sort, and column with sorting parameter (Key1:=) (They are the same here..)[/color]
             [color=green]'---------------------------------------------------------------------------------------------------------------------[/color]
 
        [color=darkblue]Next[/color] rws
    [color=green]'End making (if necerssary) new sheet and copying filtered rows to it and finally sorting by Second name[/color]
 
wks1.AutoFilterMode = [color=darkblue]False[/color] [color=green]'re - Blend in everything in sheet 1' Alternative  >>  wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter[/color]
wks1.Activate [color=green]'Activate that sheet 1 just to see it[/color]
 
TheEnd:
Application.ScreenUpdating = [color=darkblue]True[/color] [color=green]'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.[/color]
 
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'ClientAllocate2_AlanJan2015[/color]

And again Sihimfglified…

Sub ClientAllocate2_SHimpfGlified()
Dim wks1 As Worksheet: Set wks1 = ThisWorkbook.Worksheets("Master List")
wks1.Activate
        Application.DisplayAlerts = False
        Dim ws As Worksheet
        For Each ws In ActiveWorkbook.Worksheets
            If ws.Name <> wks1.Name Then ws.Delete
        Next ws
        Application.DisplayAlerts = True
vLkUpc = 4
lr = Cells.Find(What:="*", after:=Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lshtc = Columns.Count: lc = Cells(1, lshtc).End(xlToLeft).Column
 
    Let Cells(1, lshtc) = "Unique"
        For rws = 2 To lr
        On Error Resume Next
            If Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(Cells(rws, vLkUpc), Columns(lshtc), 0) = 0 Then
            Cells(Rows.Count, lshtc).End(xlUp).Offset(1) = Cells(rws, vLkUpc)
            End If
        Next rws
 
            lrUnique = Cells(Rows.Count, lshtc).End(xlUp).Row
            wks1.Activate
            Range(Cells(2, lshtc), Cells(lrUnique, lshtc)).Sort Key1:=Range(Cells(2, lshtc), Cells(lrUnique, lshtc))
            Dim myarr(): Let myarr() = Application.WorksheetFunction.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants, xlTextValues))
            wks1.Columns(lshtc).Delete
 
    For rws = 2 To UBound(myarr)
        wks1.Range(wks1.Cells(1, 1), wks1.Cells(lr, lc)).AutoFilter field:=vLkUpc, Criteria1:=myarr(rws)
        Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(rws)
 
        wks1.Range("A" & 1 & ":A" & lr & "").SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=Worksheets(myarr(rws)).Range("A1")
        Worksheets(myarr(rws)).Columns.AutoFit
            lrNewsheet = Worksheets(myarr(rws)).Cells(Rows.Count, 1).End(xlUp).Row
            lcNewsheet = Worksheets(myarr(rws)).Cells(1, Columns.Count).End(xlToLeft).Column
            Worksheets(myarr(rws)).Activate
            Worksheets(myarr(rws)).Range(Worksheets(myarr(rws)).Cells(1, 1), Worksheets(myarr(rws)).Cells(lrNewsheet, lcNewsheet)).Sort Key1:=Worksheets(myarr(rws)).Range(Worksheets(myarr(rws)).Cells(1, 2), Worksheets(myarr(rws)).Cells(lrNewsheet, 2)), order1:=xlAscending, Header:=xlYes
 
    Next rws
 
wks1.AutoFilterMode = False
 
End Sub

________________________________________________________________________

…….and now the next bit……(In the next post..)……

 

[DocAElstein]

…………………… The next bit…….

Amazing Doc, I got another one for you. .....

O.k.
. That does not look on the face of it too difficult. But at first glance I do not quite see wot you want. Remember you know your project back to front and have a clear picture in your ‘ead wot you want. It is the first time I see it so you must spell it out a bit more clearly.

. I need a clear Before and After Picture like wot you did the first time your in Post #43. The tables you posted in your Post #47 come out crap by me and it looks like you posted 2 tables, one of which was empty.?? – Take a bit more care and at least look yourself at wot you posted!!! Best is to do wot I said in my post #42. But****

. ***I do Note there is a problem with the MrExcel editor anyway for very wide tables and it may look better at your end when you look at it then at mine!! And anyway If learning all the forum Tools and stuff is a bit much at once, I can drop you a simplified code that is a very quick and easy way to give tables like the ones I did in my last Thread post #48. and may not have such a width problem / limitation. Let me know if you want it…

Alan

 

[DocAElstein]

Amazing Doc, I got another one for you. We export our AD user information into excel and was hoping there was a way to do the same separation like before. Break out the client name from the AD lines within the "Master List" to create other sheets that are in alphabetical order.

To give you an example of what my output looks like....

<tbody>
</tbody>

Column 1	Column 2	Column 3	Member Of	Column 5	Column 6
A	1	Z	CN=CLOUD_AllUsers@CLIENT NAME,OU=Groups,OU=CLIENT-NAME,OU=CLOUD,DC=cloud,DC=mycompany,DC=mynet;CN=CLIENT-NAME	AA	AA
A	1	Z	<tbody> </tbody>	BB	BB

<tbody>
</tbody>

So in my forth column I have the "Member Of" information from the AD output. The name of my client appears after the "@" symbol and runs until the first ",". Is there a way to break out each of the client names into different sheets in alphabetical order and keeping that Member Of column in alphabetical order in each sheet?

. P.s. BTW - I just had a quick go at copying that last table you sent....
. I hope you is not using . Merged cells..