AW: Daten mit Zellenbezug kopieren
28.06.2022 17:54:41
ralf_b
hmm, ein halbgetestetes Makro.
Mittels Inputbox wird der Wertesprung abgefragt. Default ist 1.
Das Programm endet wenn der letzte Wert in A eingetragen wurde.
Nach dem Eintragen wird der Wert in A gleich gelöscht.
Option Explicit
Sub werteverschieben()
Dim lRowB As Long
Dim i As Long, cnt As Long, lDelay As Long, Inputdelay
lRowB = Cells(Rows.Count, 2).End(xlUp).Row
Inputdelay = InputBox("Anzahl", "Wertesprung einstellen", 1)
If Not IsNumeric(Inputdelay) Then MsgBox ("Fehleeingabe - Abbruch"): GoTo ende
lDelay = 1
Application.ScreenUpdating = False
For i = 3 To lRowB 'Beginn in Zeile 3
If Cells(i, 3).Value Cells(i + 1, 3).Value Then
If lDelay Inputdelay Then 'Verzögerung
lDelay = lDelay + 1
Else
lDelay = 1
If Cells(cnt + 1, 1) = "" Then 'wenn in A leere Zelle
MsgBox ("Liste zu Ende")
GoTo ende
End If
Cells(i, "V").Value = Cells(cnt + 1, 1) 'wert übertragen
Cells(cnt + 1, 1).ClearContents ' a löschen
cnt = cnt + 1
End If
End If
Next
ende:
Application.ScreenUpdating = True
End Sub