Codezeile hat einen Fehler beim Kopieren

Hallo zusammen,
ich taste mich Schritt für Schritt durch den neuen Code durch. Hierzu brauche ich bitte Euren Input.
Die folgenden Codezeilen sollten eigentlich die Überschrift einfügen und darunter einen roten Punkt einfügen.
Getrennt geht der Code, aber zusammen wird der rote Punkt eingefügt, aber die Überschrift nicht mehr.
Warum ist das so?
Danke für die Hilfe.
VG Eisi :-)
' Überschrift kopieren
Set raBereich_1 = .Range("F15")
'letzte Zeile in Spalte F finden und eins tiefer gehen
loLetzteZiel_1 = .Cells(Rows.Count, "F").End(xlUp).Offset(1).Row
raBereich_1.Copy
' Überschrift einfügen
.Cells(loLetzteZiel_1, "F").PasteSpecial Paste:=xlPasteValues
'Punkt einfügen
.Cells(loLetzteZiel_1, "J").Offset(2, -4).FormulaR1C1 = "."
'Punkt rot einfärben
.Cells(loLetzteZiel_1, "J").Offset(2, -4).Select
Selection.Font.Color = vbRed

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Rudi,
in der Zelle steht schon etwas.
In der Zelle steht eine Formel und ist über 4 Zellen gruppiert.
Ich hatte gerade mehrmals den Code mit F5 ausgelöst. Bei der ersten und dritten Aktion erscheint das Name nicht und dann mehrmals hintereinander so wie es sein soll.
Neben der Überschrift rechts lasse ich auch 3 Zahlen nebeneinander einfügen und das geht immer.
So sieht im Moment der komplette Code aus:
' Positionen auflisten
'


Sub Positionen_2_SchichtPlatten()
Dim loLetzteQuelle As Long, loLetzteZiel_1 As Long, loLetzteZiel_2 As Long, loLetzteZiel_BOTTOM As Long
Dim raBereich_1 As Range
Dim raBereich_2 As Range
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
With tbl_Kalkulation
.Unprotect ("20")
' Überschrift kopieren
Set raBereich_1 = .Range("F15")
'letzte Zeile in Spalte F finden und eins tiefer gehen
loLetzteZiel_1 = .Cells(Rows.Count, "F").End(xlUp).Offset(1).Row
raBereich_1.Copy
' Überschrift einfügen
.Cells(loLetzteZiel_1, "F").PasteSpecial Paste:=xlPasteValues
.Cells(loLetzteZiel_1, "J").Offset(2, -4).FormulaR1C1 = "."
.Cells(loLetzteZiel_1, "J").Offset(2, -4).Select
Selection.Font.Color = vbRed
' Filterbereich kopieren
Set raBereich_2 = .Range("F24:F35, G24:H35, P24:P35")
loLetzteQuelle = .Cells(.Rows.Count, "A").End(xlUp).Row
loLetzteZiel_2 = .Cells(Rows.Count, "J").End(xlUp).Offset(1, 5).Row
.Range("A23:P" & loLetzteQuelle).AutoFilter Field:=2, Criteria1:="", Operator:=xlFilterValues
raBereich_2.Copy
' Kopie einfügen
.Cells(loLetzteZiel_2, "J").PasteSpecial Paste:=xlPasteValues
.Range("A23").AutoFilter
'        .Protect ("20")
End With
Application.CutCopyMode = False
Set raBereich_1 = Nothing
Set raBereich_2 = Nothing
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

'letzte Zeile in Spalte F finden und eins tiefer gehen, gleiche Spalte Set NeueZelle = .Cells(Rows.Count, "F").End(xlUp).Offset(1,0) NeueZelle = .Range("F15").Value 'Nur Wert übertragen With NeueZelle.Offset(2, 0) 'NeueZelle aber 2 Zeilen tiefer. Gleiche Spalte .FormulaR1C1 = "." 'Punkt einfügen .Font.Color = vbRed 'Punkt rot einfärben End With

Sub Positionen_2_SchichtPlatten() Dim NeueZeile As Long VBARun_optimieren True With tbl_Kalkulation .Unprotect ("20") 'letzte Zeile in Spalte F finden und eins tiefer gehen NeueZeile = .Cells(Rows.Count, "F").End(xlUp).Offset(1, 0).Row ' Überschrift übertragen, Punkt färben .Cells(NeueZeile, "F") = .Range("F15").Value .Cells(NeueZeile, "F").Offset(2, 0).FormulaR1C1 = "." .Cells(NeueZeile, "F").Offset(2, 0).Font.Color = vbRed 'Filtern: nur wo in Spalte B "" steht .Range(.Range("A23"), .Range("P99999").End(xlUp)).AutoFilter Field:=2, Criteria1:="", Operator:=xlFilterValues ' Daten übertragen .Cells(NeueZeile, "F") = .Range("F24:F35") .Cells(NeueZeile, "G").Offset(0, 2) = .Range("G24:G35") 'gleiche Ziel-Zeile (=NeueZeile), Ziel-Spalte 2 Spalten nach rechts .Cells(NeueZeile, "H") = .Range("H24:H35") 'gleiche Ziel-Zeile, gleiche Ziel-Spalte, entspricht Offset(0, 0). erspart, weil wirkungslos. .Cells(NeueZeile, "P").Offset(0, 8) = .Range("P24:P35") 'gleiche Zeile, 8 Spalten nach rechts 'Filter zurücksetzen .Range("A23").AutoFilter ' .Protect ("20") End With Application.CutCopyMode = False VBARun_optimieren = False End Sub Private Sub VBARun_optimieren(Anmachen As Boolean) Application.Calculation = IIf(Anmachen, xlCalculationManual, xlCalculationAutomatic) Application.ScreenUpdating = Not Anmachen Application.EnableEvents = Not Anmachen End Sub

Beliebteste Forumthreads (12 Monate)

Codezeile hat einen Fehler beim Kopieren

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread