Matt

I must thank you over and over as you do not realise how much you have helped me! I am not a programmer, but a good code panel beater if you get my drift.

For now the first userform opens when the workbook is opened
Code force user to stay on the same row when populating the sheet
Still needs to be done: Check for duplicate names and serial numbers and prevent user entry if true.

Below the result of the new code: (Also see attchment for current operation)

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