Public curRow 'Declare global variable (Used to check row)
Sub Auto_Open() 'Autorun code the moment workbook is opened
Userform1.Show 'Run macro within a macro by using the call statement
End Sub
Private Sub UserForm_Activate()
Range("D7").Select 'Select Location start cell
ActiveCell.Offset(0, 0).Select
Selection.End(xlDown).Select 'Move to last data cell
ActiveCell.Offset(1, 0).Select 'Move 1 row down to empty cell
curRow = ActiveCell.Row
myRow = curRow
myCol = ActiveCell.Column
If myCol <> 4 Then
MsgBox "Wrong Column - Please move to Column D"
Userform1.Hide
Exit Sub
End If
End Sub
Private Sub UserForm_Initialize()
ComboBox1.Text = "Select Category"
ComboBox1.List = GetCategories
End Sub
Private Sub ComboBox1_Click()
ComboBox2.Text = "Select Type"
ComboBox2.List = GetType(ComboBox1.Value)
End Sub
Private Sub ComboBox2_Click()
ComboBox3.Text = "Select Item"
ComboBox3.List = GetItem(ComboBox2.Value)
End Sub
Private Sub ComboBox3_Change()
End Sub
Private Sub CommandButton1_Click()
If ComboBox3.Value = "" Then Exit Sub
ActiveCell.Offset(0, 0).Select
ActiveCell.FormulaR1C1 = UCase(ComboBox1.Value) 'Write Category
ActiveCell.Offset(0, 1).Select 'Select next right empty cell
ActiveCell.FormulaR1C1 = UCase(ComboBox2.Value) 'Write Type
ActiveCell.Offset(0, 1).Select 'Select next right empty cell
ActiveCell.FormulaR1C1 = UCase(ComboBox3.Value) 'Write Item
ActiveCell.Offset(0, 1).Select 'Select next right empty cell
myRow = ActiveCell.Row
myCol = ActiveCell.Column
Userform1.Hide
ActiveCell.EntireRow.Select
ActiveCell.Interior.ColorIndex = xlNone
With Selection.Interior
.ColorIndex = 44
.Pattern = xlSolid
End With
CDQ = Chr(32)
Application.Goto Reference:=CDQ & "R" & myRow & "C" & myCol & CDQ
End Sub
Function GetCategories() As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = Intersect(Sheets("CTI").Range("A6:A65536"), Sheets("CTI").UsedRange)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetCategories = TempArr
End Function
Function GetType(ByVal vCategory As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("CTI").Range("A6:A65536"), vCategory).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetType = TempArr
End Function
Function GetItem(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("CTI").Range("B6:B65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetItem = TempArr
End Function
Function FoundRange(ByVal vRG As Range, ByVal vVal) As Range
Dim FND As Range, FND1 As Range
Set FND = vRG.Find(vVal, LookIn:=xlValues, LookAt:=xlWhole)
If Not FND Is Nothing Then
Set FoundRange = FND: Set FND1 = FND: Set FND = vRG.FindNext(FND)
Do Until FND.Address = FND1.Address
Set FoundRange = Union(FoundRange, FND): Set FND = vRG.FindNext(FND)
Loop
End If
End Function
Function InSArr(ByRef vArray() As String, ByVal vItem As String) As Long
Dim i As Long, iUB As Long
iUB = UBound(vArray)
For i = 0 To iUB
If vArray(i) = vItem Then
InSArr = i
Exit Function
End If
Next
InSArr = -1
End Function
Private Sub UserForm_Activate()
Range("N7").Select 'Select Location Information start cell
ActiveCell.Offset(0, 0).Select
Selection.End(xlDown).Select 'Move to last cell containing data
ActiveCell.Offset(1, 0).Select 'Move 1 row down to empty cell
myRow = ActiveCell.Row
'ENSURE THAT ENTRIES ARE POPULATED IN THE SAME ROW!
While curRow <> myRow
If curRow > myRow Then
ActiveCell.Offset(1, 0).Select
myRow = ActiveCell.Row
End If
If curRow < myRow Then
ActiveCell.Offset(-1, 0).Select
myRow = ActiveCell.Row
End If
Wend
myCol = ActiveCell.Column
If myCol <> 14 Then
MsgBox "Wrong Column - Please move to Column N"
UserForm2.Hide
Exit Sub
End If
End Sub
Private Sub UserForm_Initialize()
ComboBox10.Text = "Select Service Provider"
ComboBox10.List = GetServiceProvider
End Sub
Private Sub ComboBox10_Click()
ComboBox11.Text = "Select Company"
ComboBox11.List = GetCompany(ComboBox10.Value)
End Sub
Private Sub ComboBox11_Click()
ComboBox12.Text = "Select Client name"
ComboBox12.List = GetClientName(ComboBox11.Value)
End Sub
Private Sub ComboBox12_Click()
ComboBox13.Text = "Select Client Site"
ComboBox13.List = GetClientSite(ComboBox12.Value)
End Sub
Private Sub ComboBox13_Click()
ComboBox14.Text = "Select Client Region"
ComboBox14.List = GetClientRegion(ComboBox13.Value)
End Sub
Private Sub ComboBox14_Click()
ComboBox15.Text = "Select Client Department"
ComboBox15.List = GetDepartment(ComboBox14.Value)
End Sub
Private Sub CommandButton1_Click()
If ComboBox14.Value = "" Then Exit Sub
If ComboBox14.Value = "Select Department" Then Exit Sub
ActiveCell.Offset(0, 0).Select
ActiveCell.FormulaR1C1 = UCase(ComboBox10.Value) 'Write Serv Provider
ActiveCell.Offset(0, 1).Select 'Select next empty cell to the right
ActiveCell.FormulaR1C1 = UCase(ComboBox11.Value) 'Write Company
ActiveCell.Offset(0, 1).Select 'Select next empty cell to the right
ActiveCell.FormulaR1C1 = UCase(ComboBox12.Value) 'Write Client Name
ActiveCell.Offset(0, 1).Select 'Select next empty cell to the right
ActiveCell.FormulaR1C1 = UCase(ComboBox13.Value) 'Write Client Site
ActiveCell.Offset(0, 1).Select 'Select next empty cell to the right
ActiveCell.FormulaR1C1 = UCase(ComboBox14.Value) 'Write Client region
ActiveCell.Offset(0, 1).Select 'Select next empty cell to the right
ActiveCell.FormulaR1C1 = UCase(ComboBox15.Value) 'Write Client Department
ActiveCell.Offset(0, 1).Select 'Select next empty cell to the right
myCol = ActiveCell.Column
myRow = ActiveCell.Row
UserForm2.Hide
ActiveCell.EntireRow.Select 'Select entire row
ActiveCell.Interior.ColorIndex = xlNone
With Selection.Interior
.ColorIndex = 37 'Change row colour
.Pattern = xlSolid
End With
CDQ = Chr(32)
Application.Goto Reference:=CDQ & "R" & myRow & "C" & myCol & CDQ 'Go back to empty cell
End Sub
Function GetServiceProvider() As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = Intersect(Sheets("Locations").Range("A8:A65536"), Sheets("Locations").UsedRange)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetServiceProvider = TempArr
End Function
Function GetCompany(ByVal vCategory As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("Locations").Range("A8:A65536"), vCategory).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetCompany = TempArr
End Function
Function GetClientName(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("Locations").Range("B8:B65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetClientName = TempArr
End Function
Function GetClientSite(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("Locations").Range("C8:C65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetClientSite = TempArr
End Function
Function GetClientRegion(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("Locations").Range("D8:D65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetClientRegion = TempArr
End Function
Function GetDepartment(ByVal vType As String) As String()
Dim TempArr() As String, ArrCt As Long, CellRG As Range, CLL As Range
ReDim TempArr(0)
ArrCt = 0
Set CellRG = FoundRange(Sheets("Locations").Range("E8:E65536"), vType).Offset(0, 1)
If CellRG Is Nothing Then Exit Function
For Each CLL In CellRG.Cells
If InSArr(TempArr, CLL.Text) = -1 Then
ReDim Preserve TempArr(ArrCt)
TempArr(ArrCt) = CLL.Text
ArrCt = ArrCt + 1
End If
Next CLL
GetDepartment = TempArr
End Function
Function FoundRange(ByVal vRG As Range, ByVal vVal) As Range
Dim FND As Range, FND1 As Range
Set FND = vRG.Find(vVal, LookIn:=xlValues, LookAt:=xlWhole)
If Not FND Is Nothing Then
Set FoundRange = FND: Set FND1 = FND: Set FND = vRG.FindNext(FND)
Do Until FND.Address = FND1.Address
Set FoundRange = Union(FoundRange, FND): Set FND = vRG.FindNext(FND)
Loop
End If
End Function
Function InSArr(ByRef vArray() As String, ByVal vItem As String) As Long
Dim i As Long, iUB As Long
iUB = UBound(vArray)
For i = 0 To iUB
If vArray(i) = vItem Then
InSArr = i
Exit Function
End If
Next 'i
InSArr = -1
End Function