Eğer sıralamayı resimdeki yapsaydınız bu kadar sorun olmazdı.Yinede değiştirdim denersiniz olursa böyle kullanın abey.
Kodlarda alttaki gibi oldu.Bu sayede şehirler Comboboxunun sütun sayısı 4 yerine 1 olmuş oldu.Zeten mantıklısıda bu normalde.
Kayıt ekleme kodunda deneyemedim.
Kısaca Şehir adı başta olsa herşey kolay olurdu diğer sıralamalar önemli değil.

Sub IlleriAktar()



Dim x As Byte

x = Sheets("TANIMLAR").Range("A100").End(xlUp).Row

ComboBox_Sehir.ColumnCount = 1

ComboBox_Sehir.ColumnWidths = "120"

ComboBox_Sehir.RowSource = "TANIMLAR!A2:A" & x



End Sub

Sub IlceAktar()

    Dim x As Integer, bul As Range, cboSehir As MSForms.ComboBox, sehirAd As String

    Dim shTanimlar As Worksheet, son As Integer

    Dim aranan As String

    Set shTanimlar = ThisWorkbook.Sheets("TANIMLAR")

    Dim dic As Object: Set dic = CreateObject("Scripting.dictionary")

    

    With shTanimlar

        son = .Range("B" & Rows.Count).End(xlUp).Row

        For x = 2 To son

            aranan = CStr(.Cells(x, 1).Value)

            If Not dic.exists(aranan) Then

                dic.Add aranan, .Cells(x, 4).Value

            End If

        Next

    End With

    

    Set cboSehir = Me.ComboBox_Sehir

    Me.ComboBox_Ilce.Clear

    If cboSehir.Text = "" Then GoTo son

    With shTanimlar

        Set bul = .Range("a:a").Find(cboSehir.Text, , , 1)

        If Not bul Is Nothing Then

                For x = 2 To son

                    If Val(.Range("C" & x).Value) = Val(dic(CStr(bul.Value))) Then _

                            Me.ComboBox_Ilce.AddItem (.Range("B" & x).Value)

                Next

            End If

    End With

son:

    Set bul = Nothing: Set cboSehir = Nothing: Set dic = Nothing: Set shTanimlar = Nothing

    

End Sub