[color=blue]Option[/color] [color=blue]Explicit[/color]
[color=blue]Sub[/color] PolyColumnToSheet_AlanFeb2015MethodAutoFilterVisibleCellsCopyCriteriaUniqueArray()
Application.ScreenUpdating = [color=blue]False[/color] [color=lightgreen]'Not necerssary but speeds things up a bit, by turning screen updating off. Good to edit out for Debuging Purposes.[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'If anything goes wrong go to the End instead of crashing. Useful to Edit out for Debuging[/color]
[color=blue]Dim[/color] wks1 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wks1 = ThisWorkbook.Worksheets("unfiltered") [color=lightgreen]'set sheet name - Give abbreviation for "unfiltered" sheet in ThisWorkbook all Objects, Properties and Methods of Object Worksheet obtainable to view in the intellisense given after typing . Dot[/color]
[color=lightgreen]'1) Optional Start Bit to Delete Sheets / Tabs------------[/color]
Application.DisplayAlerts = [color=blue]False[/color] [color=lightgreen]'Prevents being asked everytime if you really want to delete the Workbook[/color]
[color=blue]Dim[/color] ws [color=blue]As[/color] Worksheet [color=lightgreen]'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=lightgreen]'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
[color=blue]If[/color] ws.Name <> "ASheetToKeep" And ws.Name <> wks1.Name And ws.Name <> "summary" [color=blue]Then[/color] [color=lightgreen]'Check that Worksheet name is not that of any that you want (Name property here returns name without .xlsm bit on end)[/color]
ws.Delete
[color=blue]Else[/color] [color=lightgreen]'Presumably then the worksheet name is That of the first sheet or any you wish to keep[/color]
[color=lightgreen]' 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=lightgreen]'Turn it back on[/color]
[color=lightgreen]'---End Bit to delete any Sheets / Tabs--------------------[/color]
[color=lightgreen]'Some variables used in various places[/color]
[color=blue]Dim[/color] vLkUpc [color=blue]As[/color] Long: [color=blue]Let[/color] vLkUpc = 1 [color=lightgreen]'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) If you need some sort of validation the value should only be within the range of a Byte/Integer otherwise there's no point using anything but Long.--upon/after 32-bit, Integers (Short) need converted internally anyways, so a Long is actually faster.[/color]
[color=blue]Dim[/color] rws [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Bound variable Row count used in looping[/color]
[color=blue]Dim[/color] lr [color=blue]As[/color] Long: [color=blue]Let[/color] lr = wks1.Cells.Find(what:="*", After:=wks1.Cells(1, 1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row [color=lightgreen]'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=blue]Dim[/color] lshtc [color=blue]As[/color] Long: [color=blue]Let[/color] lshtc = wks1.Columns.Count [color=lightgreen]'Number of Columns in sheet...### used as column number for tempory unique column...###[/color]
[color=lightgreen]'Let lshtc = 21 'This is useful for debugging so that you can see the tempory column of unique license plate numbers[/color]
[color=blue]Dim[/color] lc [color=blue]As[/color] Long: [color=blue]Let[/color] lc = wks1.Cells(1, lshtc).End(xlToLeft).Column [color=lightgreen]'Last column with entry in heading in unfiltered sheet. 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=lightgreen]'--------------------------------------[/color]
[color=lightgreen]'2) make an Array for Unique Search values, using a Tempory column[/color]
[color=blue]Let[/color] wks1.Cells(1, lshtc) = "Unique" [color=lightgreen]'...###The last Column inn the sheet is used. (This has an advantage of not interfering with our Method for getting lc). Here just for fun we give the array, that is to say the tempory column, a heading[/color]
[color=blue]For[/color] rws = 2 [color=blue]To[/color] lr [color=blue]Step[/color] 1 [color=lightgreen]'Going down all rows from just after heading in First sheet[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color] [color=lightgreen]'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=blue]If[/color] wks1.Cells(rws, vLkUpc) <> "" And Application.WorksheetFunction.Match(wks1.Cells(rws, vLkUpc), wks1.Columns(lshtc), 0) = 0 [color=blue]Then[/color] [color=lightgreen]'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=lightgreen]'.....Put it there[/color]
[color=blue]Else[/color] [color=lightgreen]'Else do nothing[/color]
[color=blue]End[/color] [color=blue]If[/color]
[color=blue]Next[/color] rws
[color=blue]Dim[/color] myarr() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'Array for Unique search criteria. Important to get this Dimensioning 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]
myarr() = Application.WorksheetFunction.Transpose(wks1.Columns(lshtc).SpecialCells(xlCellTypeConstants, xlTextValues).Value) [color=lightgreen]'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=lightgreen]'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=lightgreen]'---End of making an Array----------------------------------------[/color]
[color=lightgreen]'3 ) Make a New worksheet with the name of the Unique search criteria, and in the same loop.....--->>-[/color]
[color=blue]For[/color] rws = 2 [color=blue]To[/color] [color=blue]UBound[/color](myarr) [color=lightgreen]'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=lightgreen]'This blends out everything except where rows meet our search citeria[/color]
[color=blue]If[/color] [color=blue]Not[/color] Evaluate("=ISREF('" & myarr(rws) & "'!A1)") Then [color=lightgreen]'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 = "" & myarr(rws) & "" [color=lightgreen]'Make it as that after the last sheet[/color]
[color=blue]Else[/color]
Sheets("" & myarr(rws) & "").Move After:=Worksheets(Worksheets.Count) [color=lightgreen]'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=lightgreen]'.......->>---...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=lightgreen]'Copy just wot is visible after filtering[/color]
[color=lightgreen]'Worksheets(myarr(rws)).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths' Note this would need to be done as an additional line. IMPORTANT Unlike manually it must be done just before the main Paste line[/color]
Worksheets(myarr(rws)).Range("A1").PasteSpecial Paste:=[color=red]xlPasteAllUsingSourceTheme[/color] [color=lightgreen]'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=lightgreen]'Just "tidy - up" a bit[/color]
[color=lightgreen]'wks1.AutoFilterMode = False 'Normally done at end of code to make all unfiltered sheet visible. But Putting here helps with debugging[/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'This only needs to be done at the end, but doing it every time here helps in debugging by making all data re- visible on main sheet[/color]
[color=blue]Next[/color] rws
[color=lightgreen]'----End making (if necerssary) new sheet and copying filtered rows to it[/color]
wks1.Activate [color=lightgreen]'Activate that sheet 1 just to see it[/color]
TheEnd: [color=lightgreen]'We come here on erroring rather than crashing. Anything that should be done before ending the macro should be done here, to make sure it will always be dine ecen if the code crashes![/color]
wks1.AutoFilterMode = [color=blue]False[/color] [color=lightgreen]'re - Blend in everything in sheet 1[/color]
Application.ScreenUpdating = [color=blue]True[/color] [color=lightgreen]'Screen need to be turned back on or your screen will be "dead"!! Important to turn screen on here, incase anything goes wrong.[/color]
Application.CutCopyMode = [color=blue]False[/color] [color=lightgreen]'Stops screen selection flicke after Pasting[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'PolyColumnToSheet_AlanFeb2015MethodAutoFilterVisibleCellsCopyCriteriaUniqueArray()[/color]
[color=lightgreen]'[/color]
'
'I have a sheet called "unfiltered" where a lots of trucks' fuel consumption is listed in each row. The first column ("A") has the license plate numbers. And all my sheets are named according to the license plates.
[color=lightgreen]'What I want to do is to copy the rows to the given sheets based on the license plate numbers. The first row in all of the sheets are labels. So for example: A2 = MDN-229, and I want this row to be copied to the sheet name "MDN-229".[/color]
[color=lightgreen]'I have 140 trucks and a few thousand rows in the "unfiltered" sheet.[/color]
[color=lightgreen]'[/color]
'Basically what I want to do is, that after I put datas in the “unfiltered” sheet and run the macro, all of the rows should be moved in the specific sheets according to the license plate numbers (column A). So after I ran the macro the “unfiltered” sheet should be empty and the datas are moved to the correct sheet.
[color=lightgreen]'And later on when I have new datas, I just put them in the unfiltered sheet again, and run the macro.[/color]
[color=lightgreen]'[/color]
'…. forgot to mention is that later on I will want to add at least one more sheet
[color=lightgreen]'........And ws.Name <> "summary"[/color]
[color=lightgreen]' As you will be using this macro it is very wise to go through and try to understand it. As you see in understanding it you have been able to modify it yourself.[/color]
[color=lightgreen]'what I am trying to do now is that on the new sheets created by the macro, some of the columns (G and H to be precise) should be formatted as date and not "Standard". These columns on the "unfiltered" page are formatted as "Date".[/color]
[color=lightgreen]' Alan idiot: . "I overlooked that. Sorry."[/color]
[color=lightgreen]'[/color]
'.........
'Einfügen Insert 01.02.2015 00:02 .Paste
[color=lightgreen]'Formeln Formula 42036.00197 .PasteSpecial Paste:=xlPasteFormulas[/color]
[color=lightgreen]'Werte Value 42036.00197 .PasteSpecial Paste:=xlPasteValues[/color]
[color=lightgreen]'Alles Everything 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteAll[/color]
[color=lightgreen]'Formate Format .PasteSpecial Paste:=xlPasteFormats[/color]
[color=lightgreen]'Formate, dann Werte Format, followed by value 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteFormats .PasteSpecial Paste:=xlPasteValues[/color]
[color=lightgreen]'Alles mit Quelldesign Everything with source design 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteAllUsingSourceTheme[/color]
[color=lightgreen]'Alles außer Rahmen Everything except Borders 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteAllExceptBorders[/color]
[color=lightgreen]'Formeln und Zahlenwerte Formulas and number Format 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteFormulasAndNumberFormats[/color]
[color=lightgreen]'Werte und Zahlenwerte Value and Number Format 01.02.2015 00:02 .PasteSpecial Paste:=xlPasteValuesAndNumberFormats[/color]
[color=lightgreen]'.......... seperate line needed for .PasteSpecial Paste:=xlPasteColumnWidths[/color]
