VBA von ListBox in ListBox kopieren, MultiSelect

  • Excel

Es gibt 24 Antworten in diesem Thema. Der letzte Beitrag () ist von Sam85.

    VBA von ListBox in ListBox kopieren, MultiSelect

    In meinem Office Professional 2016 fehlt dem VBA einiges wie in den Tags angezeigt. Was kann man da machen? Also es fehlt Selecteditem in Listbox1.SelectedItems oder in listbox1.items gibt es kein items. Aber vielleicht kann mir jemand helfen weil ich es nicht schaffe von einer Listbox1 in eine Listbox2 zwei Spalten aus einem selektierten Eintrag zu kopieren. Mein Code ist:

    Visual Basic-Quellcode

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

    Leider wird nur die erste Spalte kopiert.

    Verschoben. Code-Tags eingefügt. (Du schreibst, dass du VBA nutzt, der Code sieht aber sehr nach VB.Net aus, daher habe ich diese Tags genutzt) ~Thunderbolt

    Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „Marcus Gräfe“ ()

    @Bredenstein Welche Tags? VB.NET solltest du in der Themenüberschrift ändern in VBA und dann nochmal zurück zu deinen Tags bzw. nicht vollständigen VBA Code.
    Und sollte es sich tatsächlich um einen VBA Code handeln, wird ein Moderator dieses Thema mit Sicherheit auch in den richtigen Forenbereich verschieben. :)

    EDIT: Du meinst nicht die Tags Items und SelectedItem oder?

    Dieser Beitrag wurde bereits 4 mal editiert, zuletzt von „Sam85“ ()

    @Bredenstein Willkommen im Forum :) . Wenn ich dich richtig verstanden habe, hast du zwei Spalten in einer ListBox und möchtest einen Eintrag davon, in eine andere ListBox kopieren? Wenn ich das richtig interpretiert habe dann hilft dir das vielleicht erstmal weiter. Zu den fehlenden Elementen (Tags) in VBA, siehe VB.NET bzw. VBA mit VB.NET verwechselt.

    UserForm Initialize

    Visual Basic-Quellcode

    1. Option Explicit
    2. Private Sub UserForm_Initialize()
    3. Dim wb As Workbook, ws As Worksheet
    4. Dim SourceSheetColumns, SourceSheetRows As Integer
    5. Dim lst As Control
    6. Dim rng_A As Range
    7. Dim str As String
    8. Set wb = ActiveWorkbook
    9. Set ws = wb.Worksheets("Tabelle1")
    10. str = "ListBox"
    11. 'SourceSheet (MaxColumns based on Row 1 & MaxRows based on Column 1)
    12. SourceSheetColumns = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    13. SourceSheetRows = ws.Cells(Rows.Count, 1).End(xlUp).Row
    14. 'SourceRange (If with Header in Row 1, begin at Row 2)
    15. Set rng_A = ws.Range(ws.Cells(2, 1), ws.Cells(SourceSheetRows, SourceSheetColumns))
    16. For Each lst In UserForm1.Controls
    17. 'All ListBoxes
    18. If TypeName(lst) = str Then
    19. With lst
    20. .ColumnCount = SourceSheetColumns
    21. .MultiSelect = fmMultiSelectExtended
    22. End With
    23. End If
    24. 'Only ListBox1
    25. If lst.Name = str & 1 Then
    26. With lst
    27. .RowSource = ws.name & "!" & rng_A.Address
    28. .ColumnHeads = True
    29. End With
    30. End If
    31. Next lst
    32. End Sub



    Add by RightMouseClick

    Visual Basic-Quellcode

    1. 'Add from lst_A to lst_B (SingleSelect & MultiSelect)
    2. Private Sub ListBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    3. Dim lst_A, lst_B As Control
    4. Dim idx_B As Integer
    5. Dim lng As Long
    6. Set lst_A = UserForm1.ListBox1
    7. Set lst_B = UserForm1.ListBox2
    8. idx_B = lst_B.ListCount
    9. For lng = 0 To lst_A.ListCount - 1
    10. If lst_A.Selected(lng) And Button = vbKeyRButton Then
    11. With lst_B
    12. .AddItem
    13. .Column(0, idx_B) = lst_A.List(lng, 0)
    14. .Column(1, idx_B) = lst_A.List(lng, 1)
    15. .Column(2, idx_B) = lst_A.List(lng, 2)
    16. .Column(2, idx_B) = Format(lst_A.List(lng, 2), "Currency")
    17. End With
    18. idx_B = idx_B + 1
    19. End If
    20. Next lng
    21. End Sub



    Remove by RightMouseClick

    Visual Basic-Quellcode

    1. 'Remove from lst_B (SingleSelect & MultiSelect)
    2. Private Sub ListBox2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    3. Dim lst_B As Control
    4. Dim lng As Long
    5. Set lst_B = UserForm1.ListBox2
    6. With lst_B
    7. For lng = .ListCount - 1 To 0 Step -1
    8. If .Selected(lng) And Button = vbKeyRButton Then .RemoveItem (lng)
    9. Next lng
    10. End With
    11. End Sub



    EDIT: Ich habe auch mal die CommandButtons entfernt und dafür die rechte Maustaste eingesetzt vbKeyRButton.

    Dieser Beitrag wurde bereits 71 mal editiert, zuletzt von „Sam85“ ()

    @Bredenstein Wenn du eine Lösung gefunden hast, kannst du sie gerne mit uns teilen.

    EDIT: Falls nicht, habe ich Post #4 um diese Funktion erweitert. Dann solltest du das Thema noch ändern in z. B. VBA von ListBox in ListBox kopieren, MultiSelect und das Tag mit der Programmiersprache von VB.NET ändern in VBA.

    Dieser Beitrag wurde bereits 9 mal editiert, zuletzt von „Sam85“ ()

    Ich habe noch keine Ahnung wie ich das alles machen kann. Ich habe aber dem Administrator geschrieben er möge es in das Forum Excel übertragen. Ja mit dem Multiselect gibt es komische Ergebnisse. Da geht es so nicht. Das Thema habe ich ändern können aber wie schaffe ich jetzt alles nach Excel?
    Dann gibt es bei Währungsspalten Probleme die ich so beseitigt habe:

    Visual Basic-Quellcode

    1. For j = 0 To LB_A34.ListCount - 1
    2. If LB_A34.Selected(j) Then
    3. With LB_B34
    4. .AddItem
    5. .Column(0, LB_B34_Rows) = LB_A34.List(j, 0)
    6. .Column(1, LB_B34_Rows) = LB_A34.List(j, 1)
    7. .Column(2, LB_B34_Rows) = LB_A34.List(j, 2)
    8. .Column(3, LB_B34_Rows) = LB_A34.List(j, 3)
    9. .Column(3, LB_B34_Rows) = Format(LB_A34.List(j, 3), "#,##0.00€")
    10. End With
    11. End If
    12. Next j


    Code-Tags eingefügt. ~Thunderbolt

    Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „Thunderbolt“ ()

    @Bredenstein Was geht denn nicht? Bzw. wo kommen komische Ergebnisse.

    Nach Excel bzw. VBA verschiebt dann ein Administrator bzw. Moderator. Das Tag oben VB.NET kannst du dann bei Thema bearbeiten ändern aber erst wenn das Thema verschoben wurde.

    EDIT: Du kannst deinen Code auch in Code Tags A oder Code Tags B einbetten, dass ist gut für die Übersicht. (Ich nehm für VBA, das Tag VB6.0). Und es wäre gut wenn der vollständige Code von dir kommt, damit ggf. das Problem nachgebaut werden kann.

    EDIT: Wegen dem MultiSelect, hast du dir meinen Code von Post #4 nochmal angeschaut?

    Dieser Beitrag wurde bereits 9 mal editiert, zuletzt von „Sam85“ ()

    Ich poste mal den ganzen code. Da sind 4 Listboxen und es sollen Listbox1 nach Listbox2, Listbox3 nach Listbox4 mit Einzelauswahl oder Multiselect bearbeitet werden. Anschließend nehme ich dann die Resultate heraus und verarbeite sie weiter.....muss ich aber noch schreiben:
    Dim lzeile, mzeile, i, j, counter12, counter34, LB_B12_Rows, LB_B34_Rows As Variant
    Dim LB_A12, LB_B12, LB_A34, LB_B34 As Control

    'Variablen

    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
    Private Sub CheckBox3_Click()

    If CheckBox3.Value = True Then
    For j = 0 To ListBox3.ListCount - 1
    ListBox3.Selected(j) = True
    Next j
    End If

    If CheckBox3.Value = False Then
    For j = 0 To ListBox3.ListCount - 1
    ListBox3.Selected(j) = False
    Next j
    End If

    End Sub

    Private Sub CheckBox4_Click()

    If CheckBox4.Value = True Then
    For j = 0 To ListBox4.ListCount - 1
    ListBox4.Selected(j) = True
    Next j
    End If

    If CheckBox4.Value = False Then
    For j = 0 To ListBox4.ListCount - 1
    ListBox4.Selected(j) = False
    Next j
    End If

    End Sub
    Private Sub CommandButton1_Click()

    Set LB_A12 = Me.ListBox1
    Set LB_B12 = Me.ListBox2

    LB_B12_Rows = LB_B12.ListCount

    For i = 0 To LB_A12.ListCount - 1
    If LB_A12.Selected(i) Then
    With LB_B12
    .AddItem
    .Column(0, LB_B12_Rows) = LB_A12.List(i, 0)
    .Column(1, LB_B12_Rows) = LB_A12.List(i, 1)
    End With
    End If
    Next i
    End Sub
    Private Sub CommandButton2_Click()

    counter = 12

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

    CheckBox2.Value = False

    End Sub
    Private Sub CommandButton3_Click()

    Set LB_A34 = Me.ListBox3
    Set LB_B34 = Me.ListBox4

    LB_B34_Rows = LB_B34.ListCount

    For j = 0 To LB_A34.ListCount - 1
    If LB_A34.Selected(j) Then
    With LB_B34
    .AddItem
    .Column(0, LB_B34_Rows) = LB_A34.List(j, 0)
    .Column(1, LB_B34_Rows) = LB_A34.List(j, 1)
    .Column(2, LB_B34_Rows) = LB_A34.List(j, 2)
    .Column(3, LB_B34_Rows) = LB_A34.List(j, 3)
    .Column(3, LB_B34_Rows) = Format(LB_A34.List(j, 3), "#,##0.00€")
    End With
    End If
    Next j
    End Sub
    Private Sub CommandButton4_Click()

    counter34 = 0

    For j = 0 To ListBox4.ListCount - 1
    If ListBox4.Selected(j - counter34) Then
    ListBox4.RemoveItem (j - counter34)
    counter34 = counter + 1
    End If
    Next j

    CheckBox4.Value = False

    End Sub

    Private Sub OptionButton1_Click()

    ListBox1.MultiSelect = 0
    ListBox2.MultiSelect = 0
    ListBox3.MultiSelect = 0
    ListBox4.MultiSelect = 0

    End Sub

    Private Sub OptionButton2_Click()

    ListBox1.MultiSelect = 1
    ListBox2.MultiSelect = 1
    ListBox3.MultiSelect = 1
    ListBox4.MultiSelect = 1

    End Sub

    Private Sub OptionButton3_Click()

    ListBox1.MultiSelect = 2
    ListBox2.MultiSelect = 2
    ListBox3.MultiSelect = 2
    ListBox4.MultiSelect = 2

    End Sub

    Option Explicit
    Private Sub UserForm_Initialize()
    ' Dim wb As Workbook, ws As Worksheet
    ' Dim SourceSheetColumns, SourceSheetRows As Integer
    ' Dim lst As Control
    ' Dim rng_A As Range
    ' Dim str As String

    ' Set wb = ActiveWorkbook
    ' Set ws = wb.ActiveSheet

    ' str = "ListBox"

    'SourceSheet (MaxColumns based on Row 1 & MaxRows based on Column 1)
    ' SourceSheetColumns = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    ' SourceSheetRows = ws.Cells(Rows.Count, 1).End(xlUp).Row

    'SourceRange (If with Header in Row 1, begin at Row 2)
    ' Set rng_A = ws.Range(ws.Cells(2, 1), ws.Cells(SourceSheetRows, SourceSheetColumns))

    ' For Each lst In UserForm1.Controls
    'All ListBoxes
    ' If TypeName(lst) = str Then
    ' With lst
    ' .ColumnCount = SourceSheetColumns
    ' .MultiSelect = fmMultiSelectExtended
    ' End With
    ' End If

    'Only ListBox1
    ' If lst.Name = str & 1 Then
    ' With lst
    ' .RowSource = rng_A.Address
    ' .ColumnHeads = True
    ' End With
    ' End If
    ' Next lst

    Sheets("Adressen").Select

    lzeile = Sheets("Adressen").UsedRange.Rows.Count + 1
    For i = 1 To lzeile
    Next

    With Me.ListBox1
    .ColumnCount = 2
    '.ColumnHeads = True
    '.RowSource = "Adressen!F1:G1"
    .RowSource = "f1:g" & lzeile
    .ColumnWidths = "3 cm;4 cm"
    End With

    With Me.ListBox2
    .ColumnCount = 2
    .ColumnWidths = "3 cm;4 cm"
    End With

    Sheets("Preise_Alle_Titel").Select

    mzeile = Sheets("Preise_Alle_Titel").UsedRange.Rows.Count + 1

    For j = 1 To mzeile
    Next

    With Me.ListBox3
    .ColumnCount = 4
    '.ColumnHeads = True
    '.RowSource = "Preise_Alle_Titel!A1:D1"
    .RowSource = "a1:d" & mzeile
    .ColumnWidths = "10 cm;1,5 cm;18 cm;2 cm"
    End With

    With Me.ListBox4
    .ColumnCount = 4
    .ColumnWidths = "10 cm;1,5 cm;18 cm;2 cm"

    End With

    OptionButton1.Value = True

    End Sub
    @Bredenstein

    Das mit dem MultiSelect scheint wohl nicht zu gehen, weil die Deklarationen von z. B. j nicht wie in meinem Beispiel als Long deklariert wurden, sondern als Variant. Schau dir bitte nochmal meinen Post #4 an (generell ist bei dir fast alles Variant bis auf die Controls).

    Welchen Zweck erfüllen die Checkboxen? Da könntest du theoretisch auch einen Elseif Zweig einsetzten.

    Wenn du die MultiSelect Eigenschaft 2 verwendest, kannst du sowohl SingleSelect als auch MultiSelect verwenden.

    Wo befindet sich denn deine Quelle für ListBox1 und ListBox3 (Sheets)? Und wie ist der Bereich (Spalten und Zeilen)? Ggf. lad eine Beispiel Datei hoch.

    Fangen wir erstmal damit an. Was läuft denn aktuell und was nicht?

    EDIT: Nicht das Einbetten deines Codes im Forum vergessen!

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Sam85“ ()

    Sam85 schrieb:

    Welchen Zweck erfüllen die Checkboxen? Da könntest du theoretisch auch einen Elseif Zweig einsetzten.
    Die sind zum alle aus-/abwählen da, obwohl es geschickter ist, das folgendermaßen zu machen:

    Visual Basic-Quellcode

    1. Private Sub CheckBox1_Click()
    2. For i = 0 To ListBox1.ListCount - 1
    3. ListBox1.Selected(i) = CheckBox1.Value
    4. Next i
    5. End Sub
    Dieser Beitrag wurde bereits 5 mal editiert, zuletzt von „VaporiZed“, mal wieder aus Grammatikgründen.

    Aufgrund spontaner Selbsteintrübung sind all meine Glaskugeln beim Hersteller. Lasst mich daher bitte nicht den Spekulatiusbackmodus wechseln.
    @Bredenstein Wenn du deinen Beitrag bearbeitest, kannst du auf Erweiterte Antwort gehen dann unterhalb des Eingabefensters Dateianhänge auswählen und die Datei hochladen.

    Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „Sam85“ ()

    @Bredenstein
    Ich kam noch nicht dazu drüber zu schauen, habe aber mein beiläufiges Testprojekt dazu hochgeladen. Du kannst dir daraus ja das ein oder andere ableiten und ggf. dein Projekt mit meinem Test abgleichen und dann nochmal schreiben.

    EDIT: Hab die Datei nochmal überarbeitet...hatte ein Problem mit der ListBox Befüllung gehabt. Bei rng = ws.Name & "!" & rng.Address, die Worksheet Bezeichnung wurde benötigt, um die ListBox von jedem Arbeitsblatt aus korrekt zu laden.
    Dateien
    • Test.zip

      (22,58 kB, 148 mal heruntergeladen, zuletzt: )

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Sam85“ ()

    @Bredenstein Freut mich zu hören. Wenn du da sonst noch was geplant hast, kann ich gerne nochmal drüber schauen.

    EDIT: Zum Loben im Forum, einfach den Hilfreich Button im entsprechenden Post betätigen.

    Dieser Beitrag wurde bereits 3 mal editiert, zuletzt von „Sam85“ ()

    Habe noch eine Kleinigkeit die ist auch unangenehm für mich weil ich da ein Feld beim überspielen immer
    vorbereiten muss. Aus einer Listbox geht ein Euro Feld nach Word aber die Spalte Cent und das Währungszeichen
    wollen nicht. Ich kann mal alles schicken aber nur wenn du Lust hast....
    Wenn ich das jetzt richtig verstehe, will sich die Währung in Word nicht korrekt darstellen? Zeig erstmal den Code mit welchen du überträgst. (Und nicht die Forum Code Tags vergessen)
    Option Explicit

    'In dieser Konstanten speichern wir uns
    'den Pfad und den Dateinamen der Adressliste (Excel)
    'Bitte entsprechend anpassen!
    Private Const sAdressDatei As String = _
    "C:\Users\Service\Documents\Kuvex\Produktion\VRM_Zeitungen.xlsm"

    'Wie heisst das Tabellenblatt, auf welchem sich die Adressen befinden?
    'Bitte entsprechend anpassen!
    Private Const sTabellenblatt As String = "Auswahl"

    Private Sub CommandButton1_Click()
    Dim oExcelApp As Object
    Dim oExcelWorkbook As Object
    Dim lZeile As Long

    'Nur wenn ein Eintrag in der Liste markiert ist, wird das Makro ausgeführt
    If ListBox1.ListIndex >= 0 Then

    'Zuerst wird die Excel Datei geöffnet
    Set oExcelApp = CreateObject("Excel.Application")
    Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)

    lZeile = 7 'Wir starten in Zeile 7, ab hier werden die Daten abgelegt
    With oExcelWorkbook.sheets(sTabellenblatt)
    Do While .Cells(lZeile, 3) <> ""
    'Wenn der Eintrag der Listbox mit dem Namen in der Adresstabelle
    'übereinstimmt, dann werden die Textmarken gefüllt!
    If ListBox1.Text = CStr(.Cells(lZeile, 3).Value) Then
    'Eintrag gefunden, Textmarken füllen
    ActiveDocument.Bookmarks("P1").Range.Text = _
    CStr(.Cells(lZeile, 6).Value)
    ActiveDocument.Bookmarks("P2").Range.Text = _
    CStr(.Cells(lZeile + 1, 6).Value)
    ActiveDocument.Bookmarks("P3").Range.Text = _
    CStr(.Cells(lZeile + 2, 6).Value)
    ActiveDocument.Bookmarks("P4").Range.Text = _
    CStr(.Cells(lZeile + 3, 6).Value)
    ActiveDocument.Bookmarks("P5").Range.Text = _
    CStr(.Cells(lZeile + 4, 6).Value)
    ActiveDocument.Bookmarks("P6").Range.Text = _
    CStr(.Cells(lZeile + 5, 6).Value)
    Exit Do
    End If

    lZeile = lZeile + 1
    Loop

    End With

    oExcelWorkbook.Close False
    oExcelApp.Quit

    Else
    MsgBox "Bitte wählen Sie einen Eintrag aus der Liste aus!", _
    vbInformation + vbOKOnly, "HINWEIS!"
    Exit Sub
    End If

    Set oExcelWorkbook = Nothing
    Set oExcelApp = Nothing
    Unload Me


    End Sub

    Private Sub CommandButton2_Click()
    Unload Me
    End Sub

    Private Sub UserForm_Initialize()
    Dim oExcelApp As Object
    Dim oExcelWorkbook As Object
    Dim lZeile As Long



    'Zuerst wird die Excel Datei geöffnet
    Set oExcelApp = CreateObject("Excel.Application")
    Set oExcelWorkbook = oExcelApp.Workbooks.Open(sAdressDatei)

    ListBox1.Clear
    lZeile = 7 'Wir starten in Zeile 7, ab hier werden die Daten abgelegt
    With oExcelWorkbook.sheets(sTabellenblatt)
    Do While .Cells(lZeile, 3) <> ""
    ListBox1.AddItem
    ListBox1.List(ListBox1.ListCount - 1, 0) = CStr(.Cells(lZeile, 3).Value)
    ListBox1.List(ListBox1.ListCount - 1, 1) = CStr(.Cells(lZeile, 4).Value)
    ListBox1.List(ListBox1.ListCount - 1, 2) = CStr(.Cells(lZeile, 5).Value)
    ListBox1.List(ListBox1.ListCount - 1, 3) = CStr(.Cells(lZeile, 6).Value)
    ListBox1.List(ListBox1.ListCount - 1, 3) = Format(.Cells(lZeile, 6), "#,##0.00€")
    lZeile = lZeile + 1
    Loop
    End With

    oExcelWorkbook.Close False
    oExcelApp.Quit

    Set oExcelWorkbook = Nothing
    Set oExcelApp = Nothing
    End Sub