Start makro fra cmd button og få listbox ind i macro

Rem VBA-koden er indsat i en Userform:
Rem ListBox1 er anvendt i stedet for ..2

Sub DeleteBlankARows()
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
       
        Dim r As Long
        For r = Cells(Rows.Count, 11).End(xlUp).Row To 1 Step -1
            If Cells(r, 11) = ListBox1.Value Then
                Rows(r).Delete
            End If
        Next r
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
   
End Sub
Private Sub CommandButton1_Click()
    DeleteBlankARows
End Sub
Private Sub UserForm_activate()    'Opbygning af test-data
    Me.ListBox1.AddItem "AAA"
    Me.ListBox1.AddItem "BBB"
    Me.ListBox1.AddItem "CCC"
    Me.ListBox1.AddItem "DDD"
End Sub

Hej Igen

Det virker næsten:-)

Jeg ville have vedhæftet en kopi af useform, men ved ikke hvordan jeg kan vedhæfte word dokument?


Når jeg markere flere felter og flytter dem fra Listbox1 til listbox2, så sletter kun hvis listbox 2 har en værdi, hvis listbox2 har flere værdier, så sker der ikke noget, kan det også løses?


Private Sub UserForm_Initialize()

  Sheets("Ark2").Select
 
End Sub
Private Sub UserForm_activate()    'Opbygning af test-data
   
    Me.ListBox1.List = Worksheets("Soeg").Range("T2:T37").Value
   
End Sub

Sub DeleteBlankARows()
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
     
        Dim r As Long
        For r = Cells(Rows.Count, 10).End(xlUp).Row To 1 Step -1
            If Cells(r, 10) = ListBox1.Value Then
                Rows(r).Delete
            End If
        Next r
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
 
End Sub
Private Sub CommandButton3_Click()

    DeleteBlankARows

End Sub

Private Sub CommandButton1_Click()

For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then ListBox2.AddItem ListBox1.List(i)
Next i

End Sub


Private Sub CommandButton2_Click()

Dim counter As Integer
counter = 0

For i = 0 To ListBox2.ListCount - 1
    If ListBox2.Selected(i - counter) Then
        ListBox2.RemoveItem (i - counter)
        counter = counter + 1
    End If
Next i

CheckBox2.Value = False

End Sub

Private Sub OptionButton3_Click()

ListBox1.MultiSelect = 2
ListBox2.MultiSelect = 2

End Sub

Private Sub CheckBox1_Click()

If CheckBox1.Value = True Then
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = True
    Next i
End If

If CheckBox1.Value = False Then
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = False
    Next i
End If

End Sub

Private Sub CheckBox2_Click()

If CheckBox2.Value = True Then
    For i = 0 To ListBox2.ListCount - 1
        ListBox2.Selected(i) = True
    Next i
End If

If CheckBox2.Value = False Then
    For i = 0 To ListBox2.ListCount - 1
        ListBox2.Selected(i) = False
    Next i
End If

End Sub

Ser på det senere...

PS: Anvend venligst KOMMENTAR når du svarer. SVAR anvendes af forslagsstiller når et indlæg forventes af kunne løse det stillede problem. Et SVAR kan så blive ACCEPTERET eller AFVIST af opgavestiller.

Har tilføjet en funktion, der anvendes i DeleteBlankARows

Sub DeleteBlankARows()
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
     
        Dim r As Long
        For r = Cells(Rows.Count, 10).End(xlUp).Row To 1 Step -1
            If erDetListeVærdi(Cells(r, 10)) = True Then
                Rows(r).Delete
            End If
        Next r
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
Private Function erDetListeVærdi(xlsVærdi)
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True _
            And ListBox1.List(i) = xlsVærdi Then
                erDetListeVærdi = True
                Exit Function
        End If
    Next i
    erDetListeVærdi = False
End Function

Tak for det, virker perfekt. Er du sød at lægge et svar

Hilsen

søren

Selv tak - et svar kommer her..