Option Explicit
Sub ZeitlböckeSuchen()
Dim selectedRange As Range
Dim currentRow As Range
Dim cell As Range
Dim cellsToExecute As Range
VerschiebenWert = -3
If TypeName(Selection) <> "Range" Then
MsgBox "Bitte wählen Sie einen Zellbereich aus, bevor Sie den Code ausführen.", vbExclamation
Exit Sub
End If
Set selectedRange = Selection
For Each currentRow In selectedRange.Rows
Set cellsToExecute = Nothing
For Each cell In currentRow.Cells
If cell.Interior.Color <> RGB(242, 242, 242) Or cell.Value = ChrW(9670) Then
If cellsToExecute Is Nothing Then
Set cellsToExecute = cell
Else
Set cellsToExecute = Union(cellsToExecute, cell)
End If
End If
Next cell
If Not cellsToExecute Is Nothing Then
ZeitblöckeEinzelnDurchlaufen cellsToExecute
End If
Next currentRow
End Sub
Sub ZeitblöckeEinzelnDurchlaufen(Zeitblock As Range)
Dim area As Range
Dim row As Range
Dim lngArea As Long
Dim i As Integer
Dim selectedArea As Range
Dim cellArea As Range
Zeitblock.Select
MsgBox "select"
If Zeitblock.Count > 0 Then
If VerschiebenWert < 0 Then
For Each row In Zeitblock.Rows
For Each area In row
area.Select
MsgBox "select negativ " & VerschiebenWert
Next area
Next row
Else
For Each cellArea In Zeitblock.Rows
For i = cellArea.Areas.Count To 1 Step -1
Set selectedArea = cellArea.Cells(1, i)
cellArea.Select
MsgBox "select positiv" & VerschiebenWert
Next i
Next cellArea
End If
Else
MsgBox "Es wurden keine Zellen ausgewählt.", vbExclamation
End If
End Sub