EXCEL VBA: Run-time error '13' Type missmatch: Listboxes - excel

Question

I saw a great tutorial from this gentleman:
https://www.businessprogrammer.com/how-to-use-listbox-in-excel-vba-userform/
But if I only make 1 data row, I get an error: Type missmatch.
Can you help me why I get this error, even if I have x Rows but the same City name, I also get this error.... strange
Its about this code part here (ex. listbox1 gives according to what is selected listbox2 listing. But if only 1 kina data is found I get this error):
Option Explicit
Private Sub UserForm_Initialize()
Dim Hauptkategorie() As Variant
Me.Caption = "Artikelsuche"
ClearFilter
' Get array of cities and apply to listbox
Hauptkategorie = GetHauptkategorieList()
ListBox1.List = Hauptkategorie
'LoadAllDataToDataList
End Sub
' Return list of Hauptkategorie
Private Function GetHauptkategorieList() As Variant
Dim rngData As Range, rngCrit As Range, rngExt As Range
Dim vReturn As Variant
Dim i As Integer
Set rngData = ArtikelDatasource.Range("A1").CurrentRegion
Set rngCrit = CategoryCriteria.Range("B1:B2")
Set rngExt = CategoryCriteria.Range("B6")
rngData.AdvancedFilter xlFilterCopy, rngCrit, rngExt, True
Set rngExt = rngExt.CurrentRegion
' Sort the cities ascending
rngExt.Sort Key1:=rngExt.Resize(1, 1), Header:=xlYes, Order1:=xlAscending
If rngExt.Rows.Count > 1 Then
vReturn = rngExt.Resize(rngExt.Rows.Count - 1).Offset(1)
Else
'Use this to return "no data" message
vReturn = noDataArray()
End If
GetHauptkategorieList = vReturn
For i = 2 To 8
With ArtikelSuche
.Controls("Listbox" & i).Clear
End With
Next i
End Function
Private Sub ListBox1_Change()
Dim rngData As Range, rngCrit As Range, rngExt As Range
Dim Ebene1kategorie() As Variant
CategoryCriteria.Range("C2").ClearContents
CategoryCriteria.Range("E2").ClearContents
CategoryCriteria.Range("G2").ClearContents
CategoryCriteria.Range("I2").ClearContents
CategoryCriteria.Range("K2").ClearContents
CategoryCriteria.Range("M2").ClearContents
CategoryCriteria.Range("O2").ClearContents
If ListBox1.ListIndex = -1 Then Exit Sub ' nothing is selected, so quit
Debug.Print ListBox1.List(ListBox1.ListIndex)
CategoryCriteria.Range("A2").Value = ListBox1.List(ListBox1.ListIndex)
Set rngData = ArtikelDatasource.Range("A1").CurrentRegion
Set rngCrit = CategoryCriteria.Range("A1").CurrentRegion
Set rngExt = ArticleCriteria.Range("A6").CurrentRegion.Resize(1)
rngData.AdvancedFilter xlFilterCopy, rngCrit, rngExt
Set rngData = rngExt.CurrentRegion
If rngData.Rows.Count > 1 Then
Set rngData = rngData.Resize(rngData.Rows.Count - 1).Offset(1)
'ListBox2.RowSource = "'" & rngData.Parent.Name & "'!" & rngData.Address
Else
Debug.Print "Error, No data for given list item, which is kinda strange...."
Exit Sub
End If
'ListBox2.Clear
Ebene1kategorie = GetEbene1List()
ListBox2.List = Ebene1kategorie
ListBox2.ListIndex = -1
End Sub
Private Function GetEbene1List() As Variant
Dim rngData As Range, rngCrit As Range, rngExt As Range
Dim vReturn As Variant
Dim i As Integer
Set rngData = ArticleCriteria.Range("A6").CurrentRegion
Set rngCrit = CategoryCriteria.Range("d1:d2")
Set rngExt = CategoryCriteria.Range("d6")
rngData.AdvancedFilter xlFilterCopy, rngCrit, rngExt, True
Set rngExt = rngExt.CurrentRegion
' Sort the cities ascending
rngExt.Sort Key1:=rngExt.Resize(1, 1), Header:=xlYes, Order1:=xlAscending
If rngExt.Rows.Count > 1 Then
vReturn = rngExt.Resize(rngExt.Rows.Count - 1).Offset(1)
Else
' Use this to return "no data" message
vReturn = noDataArray()
End If
GetEbene1List = vReturn
For i = 3 To 8
With ArtikelSuche
.Controls("Listbox" & i).Clear
End With
Next i
End Function
Private Sub ListBox2_Change()
Dim rngData As Range, rngCrit As Range, rngExt As Range
Dim Ebene2kategorie() As Variant
CategoryCriteria.Range("E2").ClearContents
CategoryCriteria.Range("G2").ClearContents
CategoryCriteria.Range("I2").ClearContents
CategoryCriteria.Range("K2").ClearContents
CategoryCriteria.Range("M2").ClearContents
CategoryCriteria.Range("O2").ClearContents
If ListBox2.ListIndex = -1 Then Exit Sub ' nothing is selected, so quit
Debug.Print ListBox2.List(ListBox2.ListIndex)
CategoryCriteria.Range("c2").Value = ListBox2.List(ListBox2.ListIndex)
Set rngData = ArtikelDatasource.Range("A1").CurrentRegion
Set rngCrit = CategoryCriteria.Range("A1").CurrentRegion
Set rngExt = ArticleCriteria.Range("A6").CurrentRegion.Resize(1)
rngData.AdvancedFilter xlFilterCopy, rngCrit, rngExt
Set rngData = rngExt.CurrentRegion
If rngData.Rows.Count > 1 Then
'If rngExt.Rows.Count < 3 Then
'Set rngData = rngData.Resize(rngData.Rows.Count - 0).Offset(1)
'ListBox2.RowSource = "'" & rngData.Parent.Name & "'!" & rngData.Address
'Else
Set rngData = rngData.Resize(rngData.Rows.Count - 1).Offset(1)
'End If
Else
Debug.Print "Error, No data for given list item, which is kinda strange...."
Exit Sub
End If
'ListBox2.Clear
Ebene2kategorie = GetEbene2List()
ListBox3.List = Ebene2kategorie
ListBox3.ListIndex = -1
End Sub
Private Function GetEbene2List() As Variant
Dim rngData As Range, rngCrit As Range, rngExt As Range
Dim vReturn As Variant
Dim i As Integer
Set rngData = ArticleCriteria.Range("A6").CurrentRegion
Set rngCrit = CategoryCriteria.Range("f1:f2")
Set rngExt = CategoryCriteria.Range("f6")
rngData.AdvancedFilter xlFilterCopy, rngCrit, rngExt, True
Set rngExt = rngExt.CurrentRegion
' Sort the cities ascending
rngExt.Sort Key1:=rngExt.Resize(1, 1), Header:=xlYes, Order1:=xlAscending
If rngExt.Rows.Count > 1 Then
'If rngExt.Rows.Count < 3 Then
' vReturn = rngExt.Resize(rngExt.Rows.Count - 0).Offset(1)
' Else
vReturn = rngExt.Resize(rngExt.Rows.Count - 1).Offset(1)
' End If
Else
' Use this to return "no data" message
vReturn = noDataArray()
End If
GetEbene2List = vReturn
For i = 4 To 8
With ArtikelSuche
.Controls("Listbox" & i).Clear
End With
Next i
End Function
(and the code goes further like this: the listboxes are all done in this way)

Answer 1

When you assign the value of a range to a variant Excel will create a string or numeric value if the range comprises a single cell, or an array if there are more than one cell in the range. Try this test:-
Private Sub TestArray()
' 271
Dim Arr1 As Variant
Dim Arr2 As Variant
With ActiveSheet
Arr1 = .Range(.Cells(1, 1), .Cells(1, 1)).Value
Arr2 = .Range(.Cells(1, 1), .Cells(2, 1)).Value
End With
Debug.Print VarType(Arr1), VarType(Arr2)
End Sub
VarType(Arr1) will return 5 or 8 (numeric or string), depending upon what cell A1 contains, and 8204 for Arr2. Any number below 8200 indicates that the variant is not an object. Debug.Print Arr1(1, 1) will return an error because Arr1 isn't an array.
In the procedure below the above test is incorporated. If the filter returned a single item and vReturn therefore is not an array the code converts the value to an array and assigns the single value to it. In consequence, vReturn(1, 1) will not throw an error as it did while this treatment was omitted.
Private Function GetEbeneList(ByVal Clm As Long) As Variant
' 271
' Clm = 4 (column D) or 6 (column F)
Dim vReturn As Variant
Dim Tmp As Variant
Dim rngData As Range, rngCrit As Range, rngExt As Range
Dim i As Integer
Set rngData = ArticleCriteria.Range("A6").CurrentRegion
With CategoryCriteria
Set rngCrit = .Range(.Cells(1, Clm), .Cells(2, Clm))
Set rngExt = .Cells(6, Clm)
End With
rngData.AdvancedFilter xlFilterCopy, rngCrit, rngExt, True
With rngExt.CurrentRegion
If .Rows.Count > 1 Then
' Sort the cities ascending
.Sort Key1:=.Resize(1, 1), Header:=xlYes, Order1:=xlAscending
vReturn = .Resize(.Rows.Count - 1).Offset(1).Value
Else
' Use this to return "no data" message
vReturn = noDataArray()
End If
End With
If VarType(vReturn) < 8200 Then
Tmp = vReturn
ReDim vReturn(1 To 1)
vReturn(1, 1) = Tmp
End If
GetEbeneList = vReturn
For i = 3 To 8
ArtikelSuche.Controls("Listbox" & i).Clear
Next i
End Function
The code is untested (last, not least, because I don't have your function NoDataArra()) and may therefore contain bugs for which I apologize. To compensate, I have made some changes.
Basically, your functions GetEbene1List and GetEbene2List are identical except for the column they refer to. Instead of creating 2 functions, one would create one and supply the column variable as an argument. This idea is incorporated above.
So, instead of your existing function call ...
Ebene1kategorie = GetEbene1List()
ListBox2.List = Ebene1kategorie
ListBox2.ListIndex = -1
You should now call ...
With ListBox2
.List = EbeneKategorie(4)
.ListIndex = -1
End With
There are more syntax changes in the code that don't need explanation. They just offer more opportunity for typos and logical errors to have crept in :-)

Answer 2

Thank you sooo much for investing your time into my question. I really had to come to this group and ask professionals, because I was soo stucked, and I will be very honest: i have really really basic idea of programming. I do also Arduino, joomla etc, but all hobby stuff. My aim was actually to have a bunch of Data from Columne A:X (as an example) and have a Userform with X listboxes.
What the first listbox does, it actually checks all the Values in Column A and only display those who are diffrent from eachother, lets say you have 400 rows, only 3 different Values, so Listbox 1 has 3 Rows in this case.
If you click a row in the Listbox1, then the Columne B will be Checked according to what was selected in Listbox1, so in this case Columne A and Listbox 2 only shows the next value so on...
This way you can have a cool Search system. I found this gentlemans Idea cool regarding the cities, so I came home today after work and solved it.
I solved it on a nooby way, but it works. And I will try your solution as well.
This is how I did it :( (just showing you 1 Listbox and the function). Yes I used errorhandle. Let me know your thinking about this solution :)
Kind regards
Private Sub ListBox2_Change()
Dim rngData As Range, rngCrit As Range, rngExt As Range
Dim Ebene2kategorie() As Variant
Dim Ebene2kategorie2(1 To 1, 1 To 1) As Variant
CategoryCriteria.Range("E2").ClearContents
CategoryCriteria.Range("G2").ClearContents
CategoryCriteria.Range("I2").ClearContents
CategoryCriteria.Range("K2").ClearContents
CategoryCriteria.Range("M2").ClearContents
CategoryCriteria.Range("O2").ClearContents
If ListBox2.ListIndex = -1 Then Exit Sub ' nothing is selected, so quit
Debug.Print ListBox2.List(ListBox2.ListIndex)
CategoryCriteria.Range("c2").Value = ListBox2.List(ListBox2.ListIndex)
Set rngData = ArtikelDatasource.Range("A1").CurrentRegion
Set rngCrit = CategoryCriteria.Range("A1").CurrentRegion
Set rngExt = ArticleCriteria.Range("A6").CurrentRegion.Resize(1)
rngData.AdvancedFilter xlFilterCopy, rngCrit, rngExt
Set rngData = rngExt.CurrentRegion
If rngData.Rows.Count > 1 Then
Set rngData = rngData.Resize(rngData.Rows.Count - 1).Offset(1)
Else
Debug.Print "Error, No data for given list item, which is kinda strange...."
Exit Sub
End If
On Error GoTo zero
Ebene2kategorie() = GetEbene2List()
ListBox3.List = Ebene2kategorie
ListBox3.ListIndex = -1
Exit Sub
zero:
Ebene2kategorie2(1, 1) = GetEbene2List()
ListBox3.List = Ebene2kategorie2
On Error GoTo 0
ListBox3.ListIndex = -1
End Sub
…
Private Function GetEbene2List() As Variant
Dim rngData As Range, rngCrit As Range, rngExt As Range
Dim vReturn2(1 To 1, 1 To 1) As Variant
Dim vReturn As Variant
Dim i As Integer
Set rngData = ArticleCriteria.Range("A6").CurrentRegion
Set rngCrit = CategoryCriteria.Range("f1:f2")
Set rngExt = CategoryCriteria.Range("f6")
rngData.AdvancedFilter xlFilterCopy, rngCrit, rngExt, True
Set rngExt = rngExt.CurrentRegion
' Sort the cities ascending
rngExt.Sort Key1:=rngExt.Resize(1, 1), Header:=xlYes, Order1:=xlAscending
If rngExt.Rows.Count > 1 And rngExt.Rows.Count < 3 Then
vReturn2(1, 1) = rngExt.Resize(rngExt.Rows.Count - 1).Offset(1)
GetEbene2List = vReturn2(1, 1)
ElseIf rngExt.Rows.Count > 1 Then
vReturn = rngExt.Resize(rngExt.Rows.Count - 1).Offset(1)
GetEbene2List = vReturn
Else
' Use this to return "no data" message
vReturn2(1, 1) = noDataArray()
End If
For i = 4 To 8
With ArtikelSuche
.Controls("Listbox" & i).Clear
End With
Next i
End Function