[color=blue]Option[/color] [color=blue]Explicit[/color]
[color=blue]Sub[/color] fbacchusMasterToShts() [color=darkgreen]'http://www.mrexcel.com/forum/excel-questions/926943-extract-columns-create-separate-sheet-based-column-criteria.html[/color]
Rem 1) Master Worksheets info.
[color=blue]Dim[/color] wsM [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wsM = ThisWorkbook.Worksheets.Item(1) [color=darkgreen]'Initial Pointer to Memory for Stuff refering to First Worksheet Object from left. Allows use of intellisense to give selection of all Properties and Methods we can get afor the wsM Object[/color]
[color=blue]Dim[/color] lr [color=blue]As[/color] [color=blue]Long[/color], lc [color=blue]As[/color] [color=blue]Long[/color] [color=darkgreen]'Variable for last table Row and Column. Varaibe of fixed memory size for a Long number. ( [color=blue]Long[/color] 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=blue]Let[/color] lr = wsM.Cells.Find(What:="*", After:=wsM.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=darkgreen]'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). Finds last row in sheet rather than row for last entry in particular cell[/color]
[color=blue]Let[/color] lc = wsM.Cells(1, Columns.Count).End(xlToLeft).Column [color=darkgreen]'Last column with entry in heading. Found by starting at last cell Range Object ( last column = Columns.Count ) in row 1, then using .End Property to "look backwards" (ToLeft) until something is found and returning a New Range Object of last cell with something in it, then applying ot that new range Object the column Property to get the column number.[/color]
[color=blue]Dim[/color] rw [color=blue]As[/color] Long [color=darkgreen]'Will be used genearally for referrencig "row" or "vertical" whole Numbers[/color]
[color=blue]Dim[/color] vLkUpc [color=blue]As[/color] [color=blue]Long[/color]: [color=blue]Let[/color] vLkUpc = 7 [color=darkgreen]'Column where names are[/color]
[color=blue]Dim[/color] rngIn [color=blue]As[/color] Range: [color=blue]Set[/color] rngIn = wsM.Range("A1", wsM.Cells(lr, lc)) [color=darkgreen]'rgnIn gives set to pointer to where Range Object of out inpuut Table is[/color]
[color=darkgreen]'1a) Optional Start Bit to Delete Sheets / Tabs------------[/color]
Application.DisplayAlerts = [color=blue]False[/color] [color=darkgreen]'Prevents being asked everytime if you really want to delete the Workbook[/color]
[color=blue]Dim[/color] ws [color=blue]As[/color] Worksheet [color=darkgreen]'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
[color=blue]For[/color] [color=blue]Each[/color] ws [color=blue]In[/color] ActiveWorkbook.Worksheets [color=darkgreen]'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
[color=blue]If[/color] ws.Name <> "ASheetToKeep" And ws.Name <> wsM.Name And ws.Name <> "Sheet1" And ws.Name <> "Tabelle1" [color=blue]Then[/color] [color=darkgreen]'Put WWorksheets here you never want to delete[/color]
ws.Delete
[color=blue]Else[/color] [color=darkgreen]'Presumably then the worksheet name is That of the first sheet so[/color]
[color=darkgreen]' do nothing (Don't delete it!)[/color]
[color=blue]End[/color] [color=blue]If[/color]
[color=blue]Next[/color] ws
Application.DisplayAlerts = [color=blue]True[/color] [color=darkgreen]'Turn it back on[/color]
[color=darkgreen]'End Bit to delete any Sheets / Tabs------------[/color]
Rem 2) Unique Names. Use the "resize an Array and put value in if it is not already there" way, as it is fast.
[color=blue]Dim[/color] vLkUp() [color=blue]As[/color] [color=blue]Variant[/color] [color=darkgreen]'Dynamic 2 D 1 "column" array for LookUpColumn The .Index Method or .Value Property used later retuns an Field of Variant Type Elements[/color]
[color=blue]Dim[/color] rngvLkUp [color=blue]As[/color] Range
[color=darkgreen]' Set rngvLkUp = Application.WorksheetFunction.Index(rngIn, 0, vLkUpc) 'Index Function with second argument ("row" co - ordinate) set to 0 will return the entire "column" given by third argument ( "column" - co ordinate ), applied to the first argument which is the grid, ( Array , Row_Number, Column_Number) http://www.excelforum.com/excel-new-users-basics/1080634-vba-1-dimensional-horizontal-and-vertical-array-conventions-ha-1-2-3-4-a.html https://usefulgyaan.wordpress.com/2013/06/12/vba-trick-of-the-week-slicing-an-array-without-loop-application-index/[/color]
[color=darkgreen]' Let vLkUp() = rngvLkUp.Value 'Returns format type (1,1) (2,1) (3,1) (4,1)...[/color]
[color=darkgreen]' Let vLkUp() = Application.WorksheetFunction.Index(rngIn, 0, vLkUpc).Value[/color]
[color=blue]Let[/color] vLkUp() = wsM.Range(wsM.Cells(1, vLkUpc), wsM.Cells(lr, vLkUpc)).Value [color=darkgreen]' .Value Property applied to Range greater than 1 cell Returns Field of Variant Type Element Values that may be assigned directly to a dynamic Array of variant types[/color]
[color=blue]Dim[/color] Eunuch() [color=blue]As[/color] [color=blue]String[/color] [color=darkgreen]'Array used for unique LookUpColumn values to be used as both Workbook Names and Search Criteria[/color]
[color=blue]ReDim[/color] Eunuch(1 [color=blue]To[/color] 1) [color=darkgreen]'We need to size it initially, but it must be a dynamic Array to allow us to increase it's size, hence not done by Dim(1 to 1) which would make it a non dynamic Array[/color]
[color=blue]For[/color] rw = 1 [color=blue]To[/color] [color=blue]UBound[/color](vLkUp(), 1) [color=blue]Step[/color] 1 [color=darkgreen]'for each "row" in the Look Up Column ( we want to look at the values there )[/color]
[color=blue]If[/color] IsError(Application.Match(vLkUp(rw, 1), Eunuch(), 0)) [color=blue]Then[/color] [color=darkgreen]'Match would error if the Unique value was not in the Array for those unique values, in which case ...[/color]
[color=blue]ReDim[/color] [color=blue]Preserve[/color] Eunuch(1 [color=blue]To[/color] [color=blue]UBound[/color](Eunuch()) + 1): [color=blue]Let[/color] Eunuch(UBound(Eunuch())) = vLkUp(rw, 1) [color=darkgreen]'.. if not there then we increase the size of the Uniques Array, then put it in, ( Note the first Array Element is empty, currently and not used***[/color]
Else: [color=blue]End[/color] [color=blue]If[/color] [color=darkgreen]'case a unique value already there for this "row". So we do nothing[/color]
[color=blue]Next[/color] rw
[color=blue]Let[/color] Eunuch(1) = "Uniques" [color=darkgreen]'***We do not use the first element of the Array, so just for fun put a Title in it. No special Reason for this[/color]
Rem 3) Main [color=blue]Loop[/color]==============================================================
[color=blue]Dim[/color] Cnt [color=blue]As[/color] [color=blue]Long[/color] [color=darkgreen]'Count for our required Sheets[/color]
[color=blue]For[/color] Cnt = 3 [color=blue]To[/color] [color=blue]UBound[/color](Eunuch()) [color=darkgreen]'Doing for all of the Names whiich start at 3rd Element of our Eunuchs Array[/color]
[color=darkgreen]'3b)An Array of our required row indicies is needed in a further code line[/color]
[color=blue]Dim[/color] rws() [color=blue]As[/color] [color=blue]String[/color], rwsT() [color=blue]As[/color] [color=blue]Long[/color] [color=darkgreen]'Arrays for these indicies, dynamic as we do not know the size. rws() uses a Strings Object Function returning an Array of strings. rwsT we fill so can choose the type[/color]
[color=blue]Dim[/color] strRws [color=blue]As[/color] [color=blue]String[/color], Indicie [color=blue]As[/color] [color=blue]Long[/color] [color=darkgreen]'A string to hold found required indicies and a Loop Bound Variable Count for for looping thriug them[/color]
[color=blue]Let[/color] strRws = "1" [color=darkgreen]'Assumne you allways want the heading row[/color]
[color=blue]For[/color] Indicie = 2 [color=blue]To[/color] lr [color=darkgreen]'For all but heading row[/color]
[color=blue]If[/color] vLkUp(Indicie, 1) = Eunuch(Cnt) [color=blue]Then[/color] [color=darkgreen]'Condition of name match[/color]
[color=blue]Let[/color] strRws = strRws & " " & Indicie [color=darkgreen]'Add indicie to Array of them[/color]
Else: [color=blue]End[/color] [color=blue]If[/color] [color=darkgreen]'No name match so do not add indicie to Array of them[/color]
[color=blue]Next[/color] Indicie
[color=blue]Let[/color] rws() = Split("" & strRws & "", " ") [color=darkgreen]'This returns a 1 d "pseudo horizontal" Array of ou indicies ( starting at base 0 )[/color]
[color=blue]ReDim[/color] rwsT(1 [color=blue]To[/color] (UBound(rws()) + 1), 1 [color=blue]To[/color] 1) [color=darkgreen]'We need this "orientation" Array later. ( +1 as rws() starts at 0 )[/color]
[color=blue]For[/color] rw = 1 [color=blue]To[/color] (UBound(rws()) + 1) [color=darkgreen]' this is to transpose to a 2 D 1 "column" Array which we need. Do it in a loop as .Transpose is crap http://excelmatters.com/2016/03/08/transpose-bug-in-2013-and-2016/[/color]
[color=blue]Let[/color] rwsT(rw, 1) = [color=blue]CLng[/color](rws(rw - 1)) [color=darkgreen]'Put appropriate value in ( -1 as rws() starts at 0 ).[/color]
[color=blue]Next[/color] rw
[color=darkgreen]'3c)An Array of required column indicies[/color]
[color=blue]Dim[/color] clms() [color=blue]As[/color] [color=blue]Variant[/color] [color=darkgreen]'Dynamic Array as values are obtained from VBA Evaluate Function that returns a Field Of Variant Type Elements[/color]
[color=blue]Dim[/color] strlc [color=blue]As[/color] String: [color=blue]Let[/color] strlc = FucshgMathsVBA(lc) [color=darkgreen]'Use Function from shg for last column letter from last column number[/color]
[color=blue]Let[/color] clms() = Evaluate("=" & "column(A:" & strlc & ")") [color=darkgreen]'Spreadsheet Column Function used for convenience when all column indicies are required[/color]
[color=blue]Let[/color] clms() = Array(1, 2, 3, 4, 5, 6, 7, 8, 9) [color=darkgreen]'Alternaive if you wish to select a specific columns ( and / or order )[/color]
[color=darkgreen]'3d)Make an Array based on our require rows and columns[/color]
[color=blue]Dim[/color] arrOut() [color=blue]As[/color] [color=blue]Variant[/color] [color=darkgreen]'Array type and Element Type to suit returned Element Field from following line.[/color]
[color=darkgreen]'Let arrOut() = Application.Index(Cells, rwsT(), clms()) ' Still bit of a mystery here http://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html http://www.eileenslounge.com/viewtopic.php?f=4&t=22534#p175261[/color]
[color=blue]Let[/color] arrOut() = Application.Index(rngIn.Value, rwsT(), clms()) [color=darkgreen]' This is a bit slower, but seems necerssary to get Date Format Correct.[/color]
[color=darkgreen]'3e) create new Worksheet if necerssary[/color]
[color=blue]Dim[/color] wsCnt [color=blue]As[/color] Worksheet [color=darkgreen]'Temporary variable for new Worksheet[/color]
[color=blue]If[/color] [color=blue]Not[/color] Evaluate("=ISREF('" & Eunuch(Cnt) & "'" & "!A1)") Then [color=darkgreen]'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]
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "" & Eunuch(Cnt) & "" [color=darkgreen]'Make it as that after the last sheet[/color]
[color=blue]Else[/color]
Sheets("" & Eunuch(Cnt) & "").Move After:=Worksheets(Worksheets.Count) [color=darkgreen]'Otherwise If the sheet is there it could be anywhere so we put it after last sheet[/color]
[color=blue]End[/color] [color=blue]If[/color]
[color=blue]Set[/color] wsCnt = ActiveSheet [color=darkgreen]'Nit necerssary but Good practice to do this after sheet is made and so is "there"[/color]
[color=darkgreen]'3f) Paste in required Final range[/color]
wsCnt.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut() [color=darkgreen]''A nice "One" liner - Use Resize Property on Top left cell Range Object of where outpit should go to resize to size of output Array and then the allowed VBA assignment of a collection of Values to a Spreadsheet Range ot an Array is used[/color]
[color=blue]Next[/color] Cnt [color=darkgreen]'Go to next Unique Name[/color]
[color=darkgreen]'End main loop================================================================[/color]
[color=blue]End[/color] [color=blue]Sub[/color]
[color=darkgreen]' http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html[/color]
[color=blue]Function[/color] FucshgMathsVBA([color=blue]ByVal[/color] lclm [color=blue]As[/color] Long) As [color=blue]String[/color] [color=darkgreen]'[/color]
' Dim vtemp
[color=darkgreen]' Let vtemp = IIf(((((lclm - 1) \ 26) - 1) \ 26) <> 0, Chr(65 + (((((lclm - 1) \ 26) - 1) \ 26) - 1 Mod 26)), "")[/color]
[color=darkgreen]' Let vtemp = Evaluate("IF(QUOTIENT(QUOTIENT(" & lclm & "-1, 26)-1, 26), CHAR(MOD(QUOTIENT(QUOTIENT(" & lclm & "-1, 26)-1, 26), 26)-1 + 65), """") ")[/color]
[color=darkgreen]' Let vtemp = IIf(((lclm - 1) \ 26) <> 0, Chr(65 + (((lclm - 1) \ 26) - 1) Mod 26), "")[/color]
[color=darkgreen]' Let vtemp = Evaluate("IF(QUOTIENT(" & lclm & "-1, 26), CHAR(MOD(QUOTIENT(" & lclm & "-1, 26)-1, 26) + 65), """")")[/color]
[color=darkgreen]' Let vtemp = IIf(lclm <> 0, Chr(65 + (lclm - 1) Mod 26), "")[/color]
[color=darkgreen]' Let vtemp = Evaluate("IF(" & lclm & ", CHAR(MOD(" & lclm & "-1, 26) + 65), """") & """"")[/color]
[color=darkgreen]' Let FucshgMathsVBA = IIf(((((lclm - 1) \ 26) - 1) \ 26) <> 0, Chr(65 + (((((lclm - 1) \ 26) - 1) \ 26) - 1 Mod 26)), "") & IIf(((lclm - 1) \ 26) <> 0, Chr(65 + (((lclm - 1) \ 26) - 1) Mod 26), "") & IIf(lclm <> 0, Chr(65 + (lclm - 1) Mod 26), "")[/color]
[color=blue]Let[/color] FucshgMathsVBA = IIf(((((lclm - 1) \ 26) - 1) \ 26), Chr(65 + (((((lclm - 1) \ 26) - 1) \ 26) - 1 Mod 26)), "") & IIf(((lclm - 1) \ 26), Chr(65 + (((lclm - 1) \ 26) - 1) Mod 26), "") & IIf(lclm, Chr(65 + (lclm - 1) Mod 26), "")
[color=darkgreen]' Let FucshgMathsVBA = Evaluate("IF(QUOTIENT(QUOTIENT(" & lclm & "-1, 26)-1, 26), CHAR(MOD(QUOTIENT(QUOTIENT(" & lclm & "-1, 26)-1, 26)-1, 26) + 65), """") & IF(QUOTIENT(" & lclm & "-1, 26), CHAR(MOD(QUOTIENT(" & lclm & "-1, 26)-1, 26) + 65), """") & IF(" & lclm & ", CHAR(MOD(" & lclm & "-1, 26) + 65), """") & """"")[/color]
[color=blue]End[/color] [color=blue]Function[/color]