Office: (Office 2013) Inhalt einer Listbox mehrfach in Tabelle ausgeben?

Hallo zusammen Forum,

Ist es möglich den ausgewählten Inhalt einer Listbox mehrfach in eine Tabelle (Druckquellle für Word) zu übertragen?
Wenn ich also z.B. 8 in eine Textbox schreibe kann ich diesen Wert dann benutzen um per Loop die Inhalte die in der Listbox
ausgewählt wurden 8 mal in die Tabelle einzutragen? Habe zu diesem Thema leider bisher nichts gefunden.
Danke

 

Hi,

was denn nun - ListBox oder TextBox oder beides? Vielleicht solltest du mal deine Mappe hochladen zum besseren Verständnis dessen, was du erreichen willst.

Bis später,
Karin

 

Hallo Karin,

Die Arbeitsmappe ist zu scheinbar zu gross (5,59MB).
Ich hole mal etwas aus. Ich versuche eine uf für den Etikettendruck zu erstellen.
Die Mappe kopiert Lagerdaten vom Hauptdoc nach Tabelle 2 in meine Arbeitsmappe. Anschliessend kann der User über eine uf
mit diversen dropdown eine vorauswahl treffen (Artikel, Bezeichnung, Lagerplatz). Die Auswahl wird von Tabelle2 geholt und erscheint in einer 3 spalten Listbox und kann makiert werden (Multiselect) anschliessend wird mit Command Button nach Tabelle 3 kopiert.
In der uf möchte ich nun eine Textbox (wenn andere mglk, gerne) in der der User die Anzahl der benötigten Etiketten eintragen kann (tbAnzahl).
Im moment habe ich nun die Anzahl aus der tbAnzahl mit CInt ausgelesen und gebe diese nach D1 in Tabelle3.
Diesen Wert möchte ich nun benutzen um per Loop alle in Tabelle3 kopierten Angaben entsprechend oft innerhalb der Tabelle3 (Header: Artikel, Bez1, Lagerplatz Txt) zu dublizieren da Tabelle3 gleichzeitig als Quelle für die entsprechenden
Etikettenvorlagen in Word dient. Bitte lass mich wissen ob weitere Daten gebraucht werden oder ob untenstehendes reicht um eine Idee zu geben was ich plane.

P.S. AutoCopy funktioniert im Prinzip (nicht mit untenstehender version) aber nur wenn alle 3 spalten vorhanden sind was nicht immer der Fall ist (Lagerplatz Txt fehlt teilweise). Dachte nun an etwas mit LastRow/LastColum.
Bin noch recht neu im Programmieren.

Vielen Dank.
Patrick

Code:

Private Sub tbAnzahl_Change()


If tbAnzahl = 0 Then
    MsgBox "Bitte Anzahl der Etiketten angeben"
ElseIf tbAnzahl = "" Then
    MsgBox "Bitte Anzahl der Etiketten angeben"
ElseIf Not IsNumeric(tbAnzahl) = True Then
    MsgBox "Das ist keine Zahl, bitte Anzahl eingeben"
End If

Sheets("Tabelle3").Range("D1") = CInt(tbAnzahl)
Call AutoCopy

Code:

Sub AutoCopy()

Dim Wiederholungen As Long
Dim wks As Worksheet

Set wks = Tabelle3

Worksheets("Tabelle3").Activate


'Application.ScreenUpdating = False

For Wiederholungen = 2 To wks.Range("D1") + 2
    wks.Range(wks.Cells(1, 1), wks.Cells(1, 3).End(xlUp)).Offset(1, 0).Select
    Selection.Copy
    wks.Range(wks.Cells(r, c), wks.Cells(r, c).End(xlUp)).Offset(1, 0).Select
    ActiveSheet.Paste
    
Next

End Sub

Ursprung von AutoCopy aus Herbers Archiv (http://www.herber.de/forum/archiv/560to564/561908_Zellinhalt_variabel_nach_unten_kopieren.html)

Code:

Option Explicit
Sub AutoCopy()
Dim Wiederholungen As Long
Application.ScreenUpdating = False
For Wiederholungen = 3 To Range("A2") + 2
Range("A1").Copy Cells(Wiederholungen, 1)
Next
End Sub

 

Hi Patrick,

ich würde nicht das Change-Ereignis der TextBox verwenden, denn dann hast du ein Problem, wenn eine zweistellige Zahl eingegeben wird. Benutze stattdessen z.B. das AfterUpdate-Ereignis, also wenn Enter gedrückt wurde um die TextBox zu verlassen. Außerdem kannst du die eingegebene Anzahl gleich mit an die Prozedur AutoCopy übergeben (roter Codeteil):

Code:

Private Sub tbAnzahl_AfterUpdate()
    If IsNumeric(tbAnzahl) Then
        If tbAnzahl > 0 Then
            [COLOR=#ff0000]AutoCopy CLng(tbAnzahl)[/COLOR]
        Else
            MsgBox "Bitte Anzahl > 0 angeben"
        End If
    Else
        MsgBox "Bitte Anzahl der Etiketten angeben"
    End If
End Sub

Das Kopieren würde dann so erfolgen können:

Code:

Sub AutoCopy([COLOR=#ff0000]lngAnzahl As Long[/COLOR])
    Dim Wiederholungen As Long
    Dim wks As Worksheet
    Set wks = Tabelle3
    For Wiederholungen = 2 To lngAnzahl
        wks.Range(wks.Cells(1, 1), wks.Cells(1, 3).End(xlUp)).Offset(1, 0).Copy _
            wks.Range(wks.Cells(r, c), wks.Cells(r, c).End(xlUp)).Offset(1, 0)
    Next
End Sub

Auf Select/Activate kann zu 99% aller Fälle verzichtet werden.


Beide Codes konnte ich selbstverständlich nicht testen, da mir deine Mappe nicht vorliegt. Wie du das dann in deine Version einbaust musst du halt selbst sehen.

Bis später,
Karin

 

Hallo Karin,

Vielen Dank erstmal für die Mühe. Werde beides direkt testen und schauen wie es läuft.

Grüsse
Patrick

 

Hallo Karin,

hat nach etwas rumbasteln funktioniert.

finale Code sieht so aus (nur das wks eingefügt):

Code:

Private Sub tbAnzahl_AfterUpdate()
    If IsNumeric(tbAnzahl) Then
        If tbAnzahl > 0 Then
            Worksheets("Tabelle3").Select
            AutoCopy CLng(tbAnzahl)
        Else
            MsgBox "Bitte Anzahl > 0 angeben"
        End If
    Else
        MsgBox "Bitte Anzahl der Etiketten angeben"
    End If
End Sub
                                                                                                                      

und AutoCopy sieht so aus:

Code:

Sub AutoCopy(lngAnzahl As Long)
'Kopiert den Inhalt von Tabelle3 um die angegebene Anzahl von Etiketten zu füllen


    Dim Wiederholungen As Long
    Dim wks As Worksheet
    Dim LastRow As Long
    Dim LastCol As Integer
    Dim copR As Range
       
    Set wks = Tabelle3
    Set copR = wks.Range("A2:C2").Resize(Cells(Rows.Count, "A").End(xlUp).Row - 1)
    
    For Wiederholungen = 2 To lngAnzahl
        With ActiveSheet
            LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        End With
        copR.Copy _
            wks.Range(wks.Cells(LastRow, 1), wks.Cells(LastRow, LastCol)).Offset(1, 0)
                    
    Next
    
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "H:\MW Analyse_Etiketten\Etikettendruck_Auto.xlsm"
Application.DisplayAlerts = True
  
    
End Sub                                                                                                                   
                                                                                                                                    

Ich weiss das sich das sicher noch optimieren lässt (Kürzerer Code und weiter Funktionen wie Sortieren der List o.ä :) ) aber das kommt. Danke nochmal für die Hilfe.
Mit besten Grüssen aus der Schweiz
Patrick