Det gør det helt klart.
Det bliver noget langt hvis der er MultiSelect i de to andre listboxe. Uden MultiSelect kan koden kortes noget ned. Men her er et bud:
Læg to listboxe i formen: De skal hedde ListBox2 og ListBox3. Jeg har som sagt lavet koden efter MultiSelect, så hvis du vil kan du sætte de to listboxes MultiSelect-property til 1 - fmMultiSelectMulti, men det er ikke tvunget..;)
Jeg har lavet en ny version af Userform_Activate, så du skal slette den gamle. Jeg har opdateret med de to nye listboxe, og desuden sat den til selv at finde enden på data (i stedet for række 175).
Den fungerer ved at når du klikker på et item i listbox 2 eller 3, så vil listbox1 blive opdateret.
Kopier hele dynen ind i formens kodemodul:
Private Sub ListBox2_Change()
Call OpdaterListBox1
End Sub
Private Sub ListBox3_Change()
Call OpdaterListBox1
End Sub
Private Sub UserForm_Activate()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, l As Long
Dim rListRange As Range
Dim pValues() As Variant
j = Worksheets("SamletListe").Range("A4").End(xlDown).Row
Set rListRange = Worksheets("SamletListe").Range(Cells(4, 1).Address & ":" & Cells(j, 5).Address)
With ListBox1
.ColumnWidths = "23;30;85;35;100"
.Clear
.BoundColumn = rListRange.Columns.Count
.ColumnCount = rListRange.Columns.Count
.ColumnHeads = True
.RowSource = Worksheets("SamletListe").Name & "!" & rListRange.Address
.ListIndex = 0
End With
With ListBox2
.ColumnWidths = "100"
.Clear
.BoundColumn = 1
.ColumnCount = 1
.ColumnHeads = True
End With
With ListBox3
.ColumnWidths = "100"
.Clear
.BoundColumn = 1
.ColumnCount = 1
.ColumnHeads = True
End With
ReDim pValues(0)
For i = 4 To j
For l = 0 To UBound(pValues)
If pValues(l) = Worksheets("SamletListe").Cells(i, 1) Then Exit For
Next l
If l = UBound(pValues) + 1 Then
k = k + 1
ReDim Preserve pValues(k)
pValues(k) = Worksheets("SamletListe").Cells(i, 1)
End If
Next i
For i = 1 To UBound(pValues)
ListBox2.AddItem pValues(i)
Next i
ReDim pValues(0)
k = 0
For i = 4 To j
For l = 0 To UBound(pValues)
If pValues(l) = Worksheets("SamletListe").Cells(i, 5) Then Exit For
Next l
If l = UBound(pValues) + 1 Then
k = k + 1
ReDim Preserve pValues(k)
pValues(k) = Worksheets("SamletListe").Cells(i, 5)
End If
Next i
For i = 1 To UBound(pValues)
ListBox3.AddItem pValues(i)
Next i
ListBox1.Selected(0) = True
Application.ScreenUpdating = True
End Sub
Private Sub OpdaterListBox1()
Application.ScreenUpdating = False
Dim pVal1() As Variant
Dim pVal5() As Variant
ReDim pVal1(0)
ReDim pVal5(0)
Dim lRækker() As Long
Dim i As Long, j As Long
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) = True Then
j = j + 1
ReDim Preserve pVal1(j)
pVal1(j) = ListBox2.List(i)
End If
Next i
j = 0
For i = 0 To ListBox3.ListCount - 1
If ListBox3.Selected(i) = True Then
j = j + 1
ReDim Preserve pVal5(j)
pVal5(j) = ListBox3.List(i)
End If
Next i
lRækker = FindRækker(pVal1, pVal5)
ListBox1.RowSource = ""
ListBox1.Clear
If UBound(lRækker) = 0 Then
MsgBox "Der er ingen poster, der opfylder begge kriterier.", vbInformation
Exit Sub
End If
For i = 1 To UBound(lRækker)
ListBox1.AddItem Worksheets("SamletListe").Cells(lRækker(i), 1).Formula
For j = 1 To 4
ListBox1.List(i - 1, j) = Worksheets("SamletListe").Cells(lRækker(i), j + 1).Formula
Next j
Next i
ListBox1.Selected(0) = True
Application.ScreenUpdating = True
End Sub
Private Function FindRækker(ByRef pV1() As Variant, ByRef pV5 As Variant) As Long()
Dim i As Long, j As Long, k As Long, l As Long, Lastrow As Long
Dim lRows() As Long, bAddRow As Boolean
ReDim lRows(0)
Lastrow = Worksheets("SamletListe").Range("A4").End(xlDown).Row
For i = 4 To Lastrow
bAddRow = False
If UBound(pV1) = 0 And UBound(pV5) = 0 Then
bAddRow = True
Else
If UBound(pV1) = 0 Then
For j = 1 To UBound(pV5)
If pV5(j) = Worksheets("SamletListe").Cells(i, 5).Formula Then
bAddRow = True
Exit For
End If
Next j
End If
If UBound(pV5) = 0 Then
For j = 1 To UBound(pV1)
If pV1(j) = Worksheets("SamletListe").Cells(i, 1).Formula Then
bAddRow = True
Exit For
End If
Next j
End If
If UBound(pV1) <> 0 And UBound(pV5) <> 0 Then
For j = 1 To UBound(pV1)
If pV1(j) = Worksheets("SamletListe").Cells(i, 1).Formula Then
For k = 1 To UBound(pV5)
If pV5(k) = Worksheets("SamletListe").Cells(i, 5).Formula Then
bAddRow = True
Exit For
End If
Next k
End If
Next j
End If
End If
If bAddRow = True Then
ReDim Preserve lRows(l + 1)
lRows(l + 1) = i
l = l + 1
End If
Next i
FindRækker = lRows
End Function
Håber du kan bruge det, men uanset var det en interessant opgave.
