Beschriftungsliste: wenn Zahl dann so oft kopieren

[eeree13]

Hallo

Wie einige der Mitglieder bin ich neu, dennoch habe ich in den Themen nichts passendes gefunden zu meiner Frage:
Ich möchte eine Bestell-Gravur-Liste erstellen, welche automatisch Zeilen widergibt.

z.Bsp.: Aus Tabelle 1 Zeile D5:D1200 soll sobald eine Zahl X (z.Bsp. 2) steht, der Name aus B (UV -1.01) & "Abstand" & C (5F3) in Tabelle 2 spalte A kopiert werden.
und das so oft wie die Zahl X. also:
Tab. 2/Zeile A1: UV -1.01 5F3
Tab. 2/Zeile A2: UV -1.01 5F3
usw.


Leider habe ich es mit kopieren und anpassen von online gefundenen Makros nicht hinbekommen.

so eine Funktion müsste doch nicht allzu schwer sein, leider weiss ich dann nicht ganz wo ich welche Daten ändern muss um auf meine Tabelle anzugleichen.

Kann da jemand helfen? Oder ev. sagen wie ich das ändern könnte:
Sub Erweitern()

    Dim lRow As Long
    Dim lCnt As Long, lCntTop As Long
    Application.ScreenUpdating = False
    With ActiveSheet
        For lRow = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
            If IsNumeric(.Cells(lRow, 2)) Then
                lCntTop = .Cells(lRow, 2)
                .Cells(lRow, 2) = 1
                For lCnt = lCntTop To 2 Step -1
                    .Rows(lRow).Insert
                    .Rows(lRow + 1).Copy Destination:=Cells(lRow, 1)
                Next lCnt
            End If
        Next lRow
    End With
    Application.ScreenUpdating = True
End Sub

Vielen Dank schon mal :43:

[Steffl]

Hallo,

wenn Du den Text in der Zelle D5 entfernst, kannst Du es mal so versuchen.

Code:

Sub Erweitern()

    Dim lRow As Long
    Dim lCnt As Long
    Application.ScreenUpdating = False
    With Worksheets("Tabelle1")
        lCnt = 1
        For lRow = 5 To .Range("B" & .Rows.Count).End(xlUp).Row
            If .Cells(lRow, 4) > 0 Then
                Worksheets("Tabelle2").Cells(lCnt, 1).Resize(.Cells(lRow, 4).Value) = .Cells(lRow, 2).Value & " " & .Cells(lRow, 3).Value
                lCnt = lCnt + .Cells(lRow, 4).Value
            End If
        Next lRow
    End With
    Application.ScreenUpdating = True
End Sub

[eeree13]

:100: Super danke für die Antwort....
werde es gleich mal ausprobieren.

Soweit mein verständnis über die logische abarbeit der Makros, schreibt es nun alle zellen so oft ab.
maximalzahl ist 5?

nunja, werde mich nochmal melden :19: :21:

[eeree13]

Super vielen Dank...  :19: Funktioniert... :15: mit Copy-Paste sogar weitere Reihen auf andere Blätter und Reihen.
Hab noch nicht raus gefunden wie ich die ersten beiden Zeilen Leer lassen kann (für überschriften oder so) und wie ich eine autoAktualisierung miteinbaue (wenn anpassung automatisch die die es nicht mehr hat löscht), aber von Hand löschen und erneut laufen lassen geht auch. Vieleicht finde ich noch was im Forum.

Das ist echt top.... Vielen Vielen Dank :18:

[Steffl]

Hallo,

Hab noch nicht raus gefunden wie ich die ersten beiden Zeilen Leer lassen kann (für überschriften oder so)

die Startzeile habe ich hier

Code:

lCnt = 1

festgelegt. Zahl einfach ändern

.... und wie ich eine autoAktualisierung miteinbaue (wenn anpassung automatisch die die es nicht mehr hat löscht),

das heißt, Du gibst (änderst oder löschst) in der Spalte D eine Zahl ein und Excel so automatisch den Eintrag in der Spalte A der Tabelle2 einfügen, ändern oder löschen?

[eeree13]

das heißt, Du gibst (änderst oder löschst) in der Spalte D eine Zahl ein und Excel so automatisch den Eintrag in der Spalte A der Tabelle2 einfügen, ändern oder löschen?

Servus

Das mit der Startzeile hat geklappt... danke

Genau, kennst du den Befehl den ich schreiben könnte, um dies gemäss deiner genaueren Beschreibung umzusetzen?

Danke dir nochmal, das ist echt beeindruckend wie einfach dir das von der Hand zu gehen scheint :35:

[Steffl]

Hallo,

versuche es mal mit dem folgenden Code

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

   Dim rngWert As Range
   Dim lngZeile As Long
   
   If Not Intersect(Target.Cells(1), Columns(4)) Is Nothing Then
       With Worksheets("Tabelle2")
           Set rngWert = .Columns(1).Find(Cells(Target.Row, 2) & " " & Cells(Target.Row, 3), lookat:=xlWhole, LookIn:=xlValues)
           If Not rngWert Is Nothing Then
               .Rows(rngWert.Row).Resize(Application.WorksheetFunction.CountIf(.Columns(1), Cells(Target.Row, 2) & " " & Cells(Target.Row, 3))).Delete
           End If
           If Not IsEmpty(Target.Cells(1)) Then
               lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
               .Cells(lngZeile, 1).Resize(Target.Cells(1).Value) = Cells(Target.Row, 2).Value & " " & Cells(Target.Row, 3).Value
           End If
       End With
   End If

End Sub

Das Makro gehört in das Codefenster der Tabelle1 siehe Erklärung http://www.online-excel.de/excel/singsel_vba.php?f=44

Es funktioniert nur bei einen Eintrag bzw. Löschen eines einzelnen Wertes.

[eeree13]

hi

Werde es morgen gleich mal ausprobieren.

Ich danke dir jedenfalls erneut, das ist echt toll das du immer so schnell einen Lösungsvorschlag hast.
Grüsse e

[eeree13]

morgen

also das mit automatisch einfügen geht tiptop, jedoch beim löschen eines einzelnen wertes  kommt die Info:

Die Delete-Methode des Range Objektes konnte nicht ausgeführt werden

Weiss leider auch nicht was das genau heisst.
Habe dir die Datei nochmal angefügt.

Guten Tag noch
Grüsse e

[Steffl]

Hallo,

in deinem Tabellenblatt sind die Zellen geschützt und da ich im Code ganze Zeile(n) lösche gibt es die Fehlermeldung. Erlaube auch das Löschen von Zeilen, dann gehts.