[color=blue]Sub[/color] justinuaapoArrayMethod()
[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. Note this is for most (unexpected) errors occuring in the program we do have others...https://app.box.com/s/8zkhjcmbxrqnlnexqpktuy41clgqm4zo http://excelmatters.com/2015/03/17/on-error-wtf/[/color]
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]Dim[/color] wks1 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wks1 = ThisWorkbook.Worksheets("JL data") [color=lightgreen]'set sheet name - Give abbreviation for "unfiltered" sheet in ThisWorkbook all Objects, Properties and Methods of [color=blue]Object[/color] Worksheet obtainable to view in the intellisense given after typing . Dot[/color]
[color=blue]Dim[/color] wks2 [color=blue]As[/color] Worksheet: [color=blue]Set[/color] wks2 = ThisWorkbook.Worksheets("SUMMARY JL")
[color=blue]Dim[/color] startDate [color=blue]As[/color] Date, stopDate [color=blue]As[/color] Date [color=lightgreen]'Can be dimensioned differently and still works[/color]
[color=blue]Let[/color] startDate = wks1.Range("C2").Value: [color=blue]Let[/color] stopDate = wks1.Range("D2").Value [color=lightgreen]'Bring in start and stop date[/color]
[color=lightgreen]' '1) Optional Start Bit to Delete Sheets / Tabs------------[/color]
[color=lightgreen]' Application.DisplayAlerts = False 'Prevents being asked everytime if you really want to delete the Workbook[/color]
[color=lightgreen]' Dim ws As Worksheet 'Tempory worksheet name. ws now has Methods and Properties of Worksheets obtained with typing . dot after it![/color]
[color=lightgreen]' For Each ws In ActiveWorkbook.Worksheets 'We could alternatively use something like ThisWorkbook, Workbooks("Itsname.xlxm")[/color]
[color=lightgreen]' If ws.Name <> "ASheetToKeep" And ws.Name <> wks1.Name And ws.Name <> "SUMMARY JL" And InStr(ws.Name, "JL") = 0 And InStr(ws.Name, "VBA") = 0 Then 'Check that Worksheet name is not that of any that you want (Name property here returns name without .xlsm bit on end)[/color]
[color=lightgreen]' ws.Delete[/color]
[color=lightgreen]' Else '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=lightgreen]' End If[/color]
[color=lightgreen]' Next ws[/color]
[color=lightgreen]' Application.DisplayAlerts = True 'Turn it back on[/color]
[color=lightgreen]' '---End Bit to delete any Sheets / Tabs--------------------[/color]
[color=lightgreen]'[/color]
' 2) Capture data, get a full Array of LookUpColumn------------------------------------
[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] xx() [color=blue]As[/color] Variant: [color=blue]Let[/color] xx() = wks1.Evaluate("" & wks1.Range("A1").Address & "").CurrentRegion.Value [color=lightgreen]'One liner VBA allowed capture of range values to a dynamic Array. (Evaluation of an address returns a Range Property...https://usefulgyaan.wordpress.com/2013/06/19/avoid-loop-for-range-calculations-evaluate/[/color]
[color=blue]Dim[/color] x() [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'Dynamic one dimensional array for unique headings....[/color]
[color=lightgreen]' can from spreadsheet column offset by 1 and so then resized to row count -1....x = Application.Transpose(.Columns(1).Offset(1, 0).Resize(.Rows.Count - 1))... or just[/color]
[color=blue]Let[/color] x() = Application.WorksheetFunction.Index(xx(), 0, vLkUpc) [color=lightgreen]'Returns format type (1,1) (2,1) (3,1) (4,1) >> Index Function with second argument (row co - ordinate) set to 0 will return the entire row given by first argument ( row - 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[/color]
[color=blue]Let[/color] x() = Application.WorksheetFunction.Transpose(x) [color=lightgreen]'working on 2 dimensional array of one column, conveniently by convenience returns 'Returns format type (1) (2) (3) (4) , a one dimension "psuedo" horizontal Array[/color]
[color=blue]Dim[/color] strRows [color=blue]As[/color] [color=blue]String[/color]
[color=lightgreen]' End 2) With [A1].CurrentRegion-------------------------------------------------------[/color]
[color=lightgreen]' 3) Use Dictionary to get Unique values (keys) of VlookUp Column----------------------------------------[/color]
[color=lightgreen]' For "Early binding"--requires library reference to MS Scripting Runtime - Tools>>References>>scrolldown and check the box next to Microsoft Scripting Runtime[/color]
[color=lightgreen]' ..Or crashes at next line.....---[/color]
[color=lightgreen]'Dim dicLookupTable As Scripting.Dictionary 'Data held with a unique "Key"or Part Number.[/color]
[color=lightgreen]'Set dicLookupTable = New Scripting.Dictionary[/color]
[color=lightgreen]' The next two lines are an alternative called Late binding. (But note some Dictionary methods and properties( Such as at the end ####) will not work with it - in those cases Early Binging must be used.[/color]
[color=blue]Dim[/color] dicLookupTable [color=blue]As[/color] Object
[color=blue]Set[/color] dicLookupTable = CreateObject("Scripting.Dictionary")
[color=lightgreen]' Late Binding is better when sharing files as I am here. Early Binding has the advantage that Excel intellisense[/color]
[color=lightgreen]' will then work for the Microsoft Scripüting Runtime stuff and give you suggestions after you type the .dot thing[/color]
dicLookupTable.CompareMode = vbTextCompare [color=lightgreen]'Not quite sure wot this does yet[/color]
[color=blue]Dim[/color] i [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Loop Bound Variable (Count) http://www.mrexcel.com/forum/excel-questions/803662-byte-backward-loop-4.html[/color]
[color=lightgreen]' The method =.Item() works in a nice way that allows us to make unique keys without assigning items http://www.snb-vba.eu/VBA_Dictionary_en.html[/color]
[color=lightgreen]' -- Usually the method .Item() is used to assign an item of some unique key to a vaiable. z = dicLookupTable.Item(x(i). If the key does not exist then it is made...convenient ehh?--- ( and no value will be given to the variable )[/color]
[color=blue]Dim[/color] z [color=blue]As[/color] [color=blue]Variant[/color] [color=lightgreen]'Subtle dimensioning reason... in method =.Item() z becomes empty "" "No value is given??" snb?? Post #12 http://www.excelforum.com/excel-programming-vba-macros/1083899-copy-and-paste-entire-row-to-second-sheet-based-on-cell-value.html[/color]
[color=blue]For[/color] i = [color=blue]LBound[/color](x()) + 1 [color=blue]To[/color] [color=blue]UBound[/color](x()) [color=lightgreen]'Start looking down column at 2 so as not to get the heading is first dic item[/color]
z = dicLookupTable.Item(x(i)) [color=lightgreen]'You will not see anything here: Post #7 http://www.excelforum.com/excel-programming-vba-macros/1083899-copy-and-paste-entire-row-to-second-sheet-based-on-cell-value.html[/color]
[color=blue]Next[/color] i
[color=blue]Dim[/color] zz() [color=blue]As[/color] Variant: [color=blue]Let[/color] zz() = dicLookupTable.keys [color=lightgreen]' The unique keys are put into a 1 Dimensional Dynamic array called zz. Probably again the variant is needed as it sees the Dictionarry object initially, the usual "one liner" type assignment[/color]
[color=lightgreen]' Dim rResults() As Variant: Let rResults() = dicLookupTable.Items() 'Extra line helpful to examine items in watch window... as dicLookupTable in watch window just the keys!! and a limited number thereof http://www.mrexcel.com/forum/excel-questions/832103-using-microsoft-scripting-runtime-dictionary-store-then-retrieve-range-objects-2.html[/color]
[color=lightgreen]'End of Part 3 initial set up Of MRSD and use of keys to get unique values ---------------------[/color]
[color=lightgreen]' 4) Array method to do the Business..[/color]
[color=blue]Dim[/color] arrResults() [color=blue]As[/color] [color=blue]String[/color] [color=lightgreen]'Array for output, will be assigned values in a loop we can dimension its content values and in next line the size[/color]
[color=blue]ReDim[/color] arrResults(1 [color=blue]To[/color] [color=blue]UBound[/color](x(), 1) - 1, 1 [color=blue]To[/color] 1) [color=lightgreen]'Dim size of output to maximum possible which is row length of input array -1 (We have here a non.Dynamic Array)[/color]
[color=blue]Dim[/color] outr [color=blue]As[/color] Long: [color=blue]Let[/color] outr = 0 [color=lightgreen]'A "row" to be incremented by every addition to output Array[/color]
[color=blue]Dim[/color] ii [color=blue]As[/color] [color=blue]Long[/color], iii [color=blue]As[/color] [color=blue]Long[/color] [color=lightgreen]'Loop Bound (Count) variables. MAIN LOOP FOR EACH UNIQUE-----------------------[/color]
[color=blue]For[/color] ii = [color=blue]LBound[/color](zz()) [color=blue]To[/color] [color=blue]UBound[/color](zz()) [color=lightgreen]'Setup outer loop. This will be used to loop through the unique values.[/color]
[color=lightgreen]'make a string of numbers to give a "row" indicie for where all occurances of the current Unique are[/color]
[color=blue]For[/color] iii = [color=blue]LBound[/color](x()) [color=blue]To[/color] [color=blue]UBound[/color](x()) [color=lightgreen]'Lower Bound by me is VLookUpColumnHeading, but no prob, I do not have this in my unique list as I looped there from 2 ## and **[/color]
[color=blue]If[/color] x(iii) = zz(ii) [color=blue]Then[/color] strRows = strRows & " " & iii [color=lightgreen]' + 1-- the usual +/-1 fiddle bit ..** my x() column has as first the heading[/color]
[color=blue]Next[/color] iii
[color=blue]Dim[/color] rws [color=blue]As[/color] Variant: [color=blue]Let[/color] rws = Trim(strRows): [color=blue]Let[/color] rws = Split(rws, " ") [color=lightgreen]'Finally rws becomes a 1 dimension1 "Psuedo" horizontal Array of the selected row inicia. " " could be left out as a space is the default[/color]
[color=blue]Dim[/color] rrws [color=blue]As[/color] Long: [color=lightgreen]'Loop Bound Variable Count for looping throught unique rows' Subtle unusual stuff here: rws is set each time to looping as many times, but any check for criteria must be done with the actual indicie value within that array!![/color]
[color=blue]For[/color] rrws = [color=blue]LBound[/color](rws) [color=blue]To[/color] [color=blue]UBound[/color](rws) [color=blue]Step[/color] 1 [color=lightgreen]'We go throug all "rows" in the rws Array for this Unique[/color]
[color=lightgreen]'The next line is the important criteria check. The "On Error / Match Pair bit" is a "bodge" to only get one unique value as is the unusual case of this program[/color]
[color=blue]If[/color] xx(rws(rrws), 2) >= startDate And xx(rws(rrws), 2) <= stopDate [color=blue]Or[/color] xx(rws(rrws), 2) = startDate [color=blue]Or[/color] xx(rws(rrws), 2) = stopDate [color=blue]Then[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]Resume[/color] [color=blue]Next[/color] [color=lightgreen]''This error handler is for the predicted error if no match, so below line errors in which case we go on at the line just after the next[/color]
[color=blue]Dim[/color] temp [color=blue]As[/color] String: [color=blue]Let[/color] temp = xx(rws(rrws), 1) [color=lightgreen]'Have to do this intermediate step as criteria to search for in Match only accepts something like a string in it's first argument.[/color]
[color=blue]If[/color] Application.WorksheetFunction.Match(temp, arrResults(), 0) = -1234 [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, the predicted error occurs.......This is part of "Match On Error Pair" trick for getting Unique values. (See here http://www.excelforum.com/excel-new-users-basics/1072093-match-with-on-error-on-error-resume-next-works-on-error-goto-only-works-once-err-clear.html ). Otherwisde it does not crash as it gets a Long Number, ( the indicie going down the row, 1 , 2 , 3 or 4 etc. ) - But it will not get -1234 ! - it accepts thogh syntaxly this as OK, - most people write 0 here.[/color]
[color=blue]Let[/color] outr = outr + 1 [color=lightgreen]'If the above errored we had no unique value yet, so we can put one in[/color]
[color=blue]Let[/color] arrResults(outr, 1) = xx(rws(rrws), 1)
[color=blue]Else[/color] [color=lightgreen]'We already had a Unique that met date criteria so we do not need another[/color]
[color=blue]End[/color] [color=blue]If[/color] [color=lightgreen]'End of "On Error / Match Pair bit"[/color]
[color=blue]Else[/color] [color=lightgreen]'Date criteria not met, so no entry in output Array[/color]
[color=blue]End[/color] [color=blue]If[/color] [color=lightgreen]'End of main criteria check[/color]
[color=blue]On[/color] [color=blue]Error[/color] [color=blue]GoTo[/color] TheEnd [color=lightgreen]'We no longer expecting an error, so we switch back on the error handler as soon as possible for handling unexpected errors[/color]
[color=blue]Next[/color] rrws [color=lightgreen]'This goes back to the next occurance "row" if there is one of the unique. For this particular program it is not rally needed[/color]
[color=blue]Let[/color] strRows = "" [color=lightgreen]'Empty the String for collecting the row indicie of the next unique occurrances[/color]
[color=blue]Next[/color] ii [color=lightgreen]' Continue to next unique value[/color]
[color=lightgreen]' End 4) MAIN LOOP FOR EACH UNIQUE---------------------------------------------------------------[/color]
[color=lightgreen]' 5) Output to SUMMARY sheet[/color]
[color=blue]Let[/color] wks2.Range("A1").Resize(1, 1).Value = Array("Code", "Date") [color=lightgreen]'A taypical step that looks cleverer then it is, I resize first cell to a range including all headings I want, and then VBA lets me assign the values in a (Heasding here) Array to the cells in a simplw = step[/color]
[color=blue]Let[/color] wks2.Range("A2").Resize(UBound(arrResults(), 1), 1).Value = arrResults() [color=lightgreen]'Similat to the above just convenient to resize to size of Arrray i am actually outputing ( Assuming there are more than one value of the Uniques then I output empty values also, but that is useful as it actually clears those cells in case they had any in from a last run where there were more in the output Array[/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]
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]
[color=blue]Set[/color] dicLookupTable = [color=blue]Nothing[/color]
[color=lightgreen]' 'Err.Message 'Give Error message using property to give infomation from the Err Object which gets info Error stored when an error occurs..[/color]
[color=blue]End[/color] [color=blue]Sub[/color] [color=lightgreen]'justinuaapoArrayMethod()[/color]
