Clever-Excel-Forum - Beschriftungsliste: wenn Zahl dann so oft kopieren

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. Dodgy

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:

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

: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? Dodgy

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

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:

Hallo,

(21.10.2015, 08:35)eeree13 schrieb: [ -> ]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

(21.10.2015, 08:35)eeree13 schrieb: [ -> ].... 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?

(21.10.2015, 18:25)Steffl schrieb: [ -> ]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:

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.

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

morgen

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

Zitat: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

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.