Excel

Hvordan er data organiseret? I givetfald er du velkommen til at sende filen eller uddrag heraf - @-adresse under min profil.

Rem Version 2
Rem =========

Const førsteRæk = 4

Dim beregnArk As Worksheet
Dim antalRæk As Long
Rem ======== USERFORM-OBJEKTER ANVENDES ========
Private Sub CommandButton1_Click()
Rem Test om alle kriterier er valgt
    If Me.ListBox1.ListIndex <> -1 And _
        Me.ListBox2.ListIndex <> -1 And _
            Me.ListBox3.ListIndex <> -1 Then
                sætKriterierBeregningsark
               
                rydGlTal
                udførSøgning
               
                beregnArk.Activate
                Unload UserForm1
    Else
        MsgBox "Alle kriterier er ikke valgt", vbOKOnly
    End If
End Sub
Rem ======== OPSTART AF USERFORM ========
Private Sub UserForm_activate()
    antalRæk = findAntalRækker
    Set beregnArk = ActiveWorkbook.Sheets("Beregningsark")
   
Rem opbyg Kriterie-lister
    bygListeDato
   
    bygListePostnr
    Module1.sortering "Listbox2"
   
    bygListebranchekode
    Module1.sortering "Listbox3"
   
End Sub
Private Function findAntalRækker()
    findAntalRækker = ActiveCell.SpecialCells(xlLastCell).Row
End Function
Private Sub bygListeDato()
    bygliste "A", "ListBox1"
End Sub
Private Sub bygListePostnr()
    bygliste "C", "Listbox2"
End Sub
Private Sub bygListebranchekode()
    bygliste "D", "ListBox3"
    bygliste "E", "ListBox3"
    bygliste "F", "ListBox3"
End Sub
Private Sub bygliste(Kol, listenavn)
Dim ræk As Long, cc As Object, værdi As Variant
    Set cc = UserForm1.Controls(listenavn)
   
    For ræk = førsteRæk To antalRæk
        værdi = CStr(Range(Kol & ræk))
        If værdi <> "" Then
            If findesVærdi(værdi, cc) = False Then
                cc.AddItem værdi
            End If
        End If
    Next ræk
End Sub
Private Function findesVærdi(værdi, listeControl)
Dim ix As Long
    For ix = 0 To listeControl.ListCount - 1
        If listeControl.List(ix) = CStr(værdi) Then
            findesVærdi = True
            Exit Function
        End If
    Next ix
    findesVærdi = False
End Function
Rem ======== USERFORM-OK ER AKTIVERET ========
Private Sub sætKriterierBeregningsark()
    With beregnArk
        .Range("A2") = Me.ListBox1
        .Range("B2") = Me.ListBox2
        .Range("C2") = Me.ListBox3
    End With
End Sub
Private Sub rydGlTal()
    With beregnArk
        .Range("B4:B7").ClearContents
        .Range("F4:F9").ClearContents
    End With
End Sub
Private Sub udførSøgning()
Dim ræk As Long
    For ræk = førsteRæk To antalRæk
        If CStr(Range("A" & ræk)) = Me.ListBox1 And _
            CStr(Range("C" & ræk)) = Me.ListBox2 And _
                CStr(Range("D" & ræk)) = Me.ListBox3 Or _
                    CStr(Range("E" & ræk)) = Me.ListBox3 Or _
                        CStr(Range("F" & ræk)) = Me.ListBox3 Then
                            optælMatch ræk
        End If
    Next ræk
End Sub
Private Sub optælMatch(ræk)
Rem optæl til bestyrelsesændring
    optælling "H", "K", ræk, "B", 4
   
Rem optæl til anciennitet
    optælling "M", "R", ræk, "F", 4
End Sub
Private Sub optælling(fraKol, tilKol, fraRæk, Kol, Ræk1)
Dim cc, count As Byte, ræk As Long
    ræk = Ræk1
    For Each cc In Range(fraKol & fraRæk & ":" & tilKol & fraRæk).Cells
        If cc.Value <> "" Then
            With beregnArk
                .Range(Kol & ræk).Value = .Range(Kol & ræk).Value + cc.Value
            End With
        End If
        ræk = ræk + 1
    Next
End Sub
Rem
Rem ======== BUBBLE-SORT ========
Rem
Dim antal As Long, cc As Object
Dim vektor(), ix As Long, j As Long, byt
Public Sub sortering(listenavn)
    Set cc = UserForm1.Controls(listenavn)

    antal = cc.ListCount
   
    ReDim vektor(antal)

Rem sæt værdier i vektor
    For ix = 1 To antal
        vektor(ix) = cc.List(ix - 1)
    Next ix
   
Rem udfør sortering
    For ix = antal - 1 To 1 Step -1
        For j = 1 To ix
            If vektor(j) > vektor(j + 1) Then
                byt = vektor(j)
                vektor(j) = vektor(j + 1)
                vektor(j + 1) = byt
            End If
        Next j
    Next ix
   
Rem flyt tilbage i liste
    cc.Clear
   
    For ix = 1 To antal
        cc.AddItem vektor(ix)
    Next ix
   
    Set cc = Nothing
End Sub