Option Explicit
Public Function UniqueItems(ArrayIn, Optional Add2Arr As Variant, Optional count As Variant) As Variant
' Function will produce an array of Unique Items in a range or another array.
'Declarations
Dim Unique() As Variant
Dim Element As Variant
Dim i As Long
Dim NumUnique As Long
Dim IsInArray As Boolean
' If 2nd argument is missing, assign default value.
' Add2Arr is if the results will be added to an existing array, rather than
' a new array.
' Like so, myarray = UniqueItems(Range("A1:B10"), myarray)
' in this case, myarray already contains array data and we will just add the results
' to the end of it. Argument is optional and will produce a new array if 2nd arguement
' is missing.
If IsMissing(count) Then count = False
If Not IsMissing(Add2Arr) Then
Unique = Add2Arr
NumUnique = UBound(Add2Arr) + 1
End If
'Loop through the array
For Each Element In ArrayIn
IsInArray = False
' If Arr has not been established, skip the loop
' This if line only works with arrays that have been declared
' like this. Dim myarray() as variant
' if an array is declared with just Dim myarray as variant
' This will not determine if the array has been initialized
' it would instead fail. I have another function altogether
' to determine if array's have been initialized, but this works
' for a one time use. The double not states that if it is initialized
' it will run the for loop.
If Not ((Not Unique) = -1) Then
'Looks at each element of the array it is building (or each element in
'the existing array if supplied) and determines if the element already
'exists in the array.
For i = LBound(Unique) To UBound(Unique)
If Element = Unique(i) Then
IsInArray = True
Exit For
End If
Next i
End If
'If the element does not exist in the array, we will then add it to the array
'Also eliminating any empty elements as we only want actual data, not blank data
If IsInArray = False And Element <> "" Then
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
NumUnique = NumUnique + 1
IsInArray = True
End If
Next Element
'outputs the array, unless count is specified, then it will give a count of
'unique items in the range or array.
If count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function
Sub Input2Sheets()
'Declarations
Dim lr As Long
Dim i As Long
Dim NewWS As Worksheet
Dim InputSHT As Worksheet
'Sets the input worksheet so we can refer to it by it's short name InputSHT
Set InputSHT = Sheets("Input Sheet")
Dim JobTypeARR As Variant
lr = InputSHT.Range("B" & Rows.count).End(xlUp).Row
'Uses the above function to produce a list of unique job types.
JobTypeARR = UniqueItems(Range("B2", "B" & lr))
'Loop through the job types, create the sheets and move pertinant data to new sheet
For i = LBound(JobTypeARR) To UBound(JobTypeARR)
'Sets the criteria to use for the Advanced Filter
InputSHT.Cells(1, "G").Value = InputSHT.Cells(1, "B").Value
InputSHT.Cells(2, "G").Value = "=" & """" & "=" & JobTypeARR(i) & """"
'Adds the new sheet and names it
Sheets.Add.Name = JobTypeARR(i)
'sets New Worksheet so it can be referred to by its short name "NewWS"
'Since its only used once, its not really needed and can refer to the sheet
'name directly, but I figured it would be nice to have it if there was
'anything else you'd like to do with the New worksheet before you moved
'on to adding the next one.
Set NewWS = Sheets(JobTypeARR(i))
'Advanced Filter, uses the Criteria range set above to pull all records
'matching the jobtype.
InputSHT.Range("A1:D" & lr).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=InputSHT.Range("G1:G2"), _
CopyToRange:=NewWS.Range("A1:D1"), Unique:=True
Next i
'Clears the criteria range as its not needed afterwards.
InputSHT.Range("G1:G2").ClearContents
End Sub
