VBA Zahk mit Text (1 von 2) etc

Hallo und guten Abend,
eine besteimmte bereich wird untereinander kopiert, dann wird an hand der Anzahl der Kopieen (Zelle G3) ein zähler gesetzt.
1
2
3
etc
codezeile .Cells((ii * 6) + 6, 1).Value = ii + 1
ich möchte aber gerne anhand der kopieen eien ergänzung mit Text
also 4 Kopienen:
1 von 4
2 von 4
3 von 4
4 von 4
CODE
Option Explicit
Sub Kopieren_Print()
Dim rngVor As Range, lngZ As Long, lngS As Long, rngR As Range, ii As Long
Application.ScreenUpdating = False
With Sheets("Eingabe_Etikett")
Set rngVor = .Range("A1:E6")
lngS = rngVor.Columns.Count
lngZ = rngVor.Rows.Count * .Range("G3").Value
End With
With Sheets("Etikett_print").Range("A1").Resize(lngZ, lngS)
.EntireColumn.Clear ' löschen
rngVor.Copy ' kopieren
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteColumnWidths
.Cells.Interior.ColorIndex = xlNone
Application.CutCopyMode = False
For lngZ = 1 To rngVor.Rows.Count ' Zeilenhöhen
Set rngR = .Rows(lngZ)
For ii = 1 To Sheets("Eingabe_Etikett").Range("G3").Value - 1
.Cells((ii * 6) + 6, 1).Value = ii + 1
Set rngR = Union(rngR, .Rows(lngZ + ii * rngVor.Rows.Count))
Next ii
rngR.RowHeight = rngVor.Rows(lngZ).RowHeight
Next lngZ
End With
beste dank im Voraus
Hans

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Hans,
da ich die original-Aufgabenstellung nicht kenne, kann ich nur mutmaßen. Ich gehe davon aus, dass das erste Etikett ab A1 vorhanden ist und als Kopiervorlage dient. Dann müste es so gehen.
Allerdings beginnt dann das erste Etikett in Zeile 1 und das nächste folgt ab Zeile 12. Ist das so gewollt? Falls nicht, müsstest Du das "+6" in der von Dir geposteten Zeile wegnehmen. Oder poste nochmal die ursprüngliche Aufgabenstellung.

Sub Kopieren_Print()
Dim rngVor As Range, lngZ As Long, lngS As Long, rngR As Range, ii As Long
Application.ScreenUpdating = False
With Sheets("Eingabe_Etikett")
Set rngVor = .Range("A1:E6")
lngS = rngVor.Columns.Count
lngZ = rngVor.Rows.Count * .Range("G3").Value
End With
With Sheets("Etikett_print").Range("A1").Resize(lngZ, lngS)
.EntireColumn.Clear ' löschen
rngVor.Copy ' kopieren
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteColumnWidths
.Cells.Interior.ColorIndex = xlNone
Application.CutCopyMode = False
Worksheets("Etikett_print").Range("A1") = "1 von " & Worksheets("Eingabe_Etikett").Range("G3"). _
Value
For lngZ = 1 To rngVor.Rows.Count ' Zeilenhöhen
Set rngR = .Rows(lngZ)
For ii = 1 To Sheets("Eingabe_Etikett").Range("G3").Value - 1
.Cells((ii * 6) + 6, 1).Value = ii + 1 & " von " & Sheets("Eingabe_Etikett").Range("G3").Value
Set rngR = Union(rngR, .Rows(lngZ + ii * rngVor.Rows.Count))
Next ii
rngR.RowHeight = rngVor.Rows(lngZ).RowHeight
Next lngZ
End With
End Sub

Gruß
Regina

For ii = 1 To Sheets("Eingabe_Etikett").Range("G3") - 1 .Cells(1, 1).Offset(ii * 6, 0) = ii & " von " & Sheets("Eingabe_Etikett").Range("G3") Set rngR = Union(rngR, .Rows(lngZ + ii * rngVor.Rows.Count)) Next ii

Sub Kopieren_Print() Dim rngVor As Range, lngZ As Long, lngS As Long, rngR As Range, ii As Long Application.ScreenUpdating = False With Sheets("Eingabe_Etikett") Set rngVor = .Range("A1:E6") lngS = rngVor.Columns.Count lngZ = rngVor.Rows.Count * .Range("G3").Value End With With Sheets("Etikett_print").Range("A1").Resize(lngZ, lngS) .EntireColumn.Clear ' löschen rngVor.Copy ' kopieren .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats .PasteSpecial xlPasteColumnWidths .Cells.Interior.ColorIndex = xlNone Application.CutCopyMode = False For lngZ = 1 To rngVor.Rows.Count ' Zeilenhöhen Set rngR = .Rows(lngZ) For ii = 1 To Sheets("Eingabe_Etikett").Range("G3") - 1 .Cells(1, 1).Offset(ii * 6, 0) = ii & " von " & Sheets("Eingabe_Etikett").Range("G3") Set rngR = Union(rngR, .Rows(lngZ + ii * rngVor.Rows.Count)) Next ii rngR.RowHeight = rngVor.Rows(lngZ).RowHeight Next lngZ End With End Sub

Dim rngVor As Range, lngZ As Long, lngS As Long, rngR As Range, ii As Long Application.ScreenUpdating = False With Sheets("Eingabe_Etikett") Set rngVor = .Range("A1:E6") lngS = rngVor.Columns.Count lngZ = rngVor.Rows.Count * .Range("G3").Value End With With Sheets("Etikett_print").Range("A1").Resize(lngZ, lngS) .EntireColumn.Clear ' löschen rngVor.Copy ' kopieren .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats .PasteSpecial xlPasteColumnWidths .Cells.Interior.ColorIndex = xlNone Application.CutCopyMode = False For lngZ = 1 To rngVor.Rows.Count ' Zeilenhöhen Set rngR = .Rows(lngZ) For ii = 1 To Sheets("Eingabe_Etikett").Range("G3").Value .Cells((ii * 6), 1).Value = ii & " von " & Sheets("Eingabe_Etikett").Range("G3").Value Set rngR = Union(rngR, .Rows(lngZ + ii * rngVor.Rows.Count)) Next ii rngR.RowHeight = rngVor.Rows(lngZ).RowHeight Next lngZ End With End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread