[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]
Merged cells..
