Få celler med samme navn til at blive til én celle

Indsættes under relevante ark:

Const startRæk = 1
Const slutRæk = 14
Dim antalRæker As Long, interval As String, aktivitet As String
Dim redRæk As Long, fra As String, til As String
Sub optimerTidsplan()
    redRæk = slutRæk + 1
   
    opsætAktivitet startRæk
   
    For ræk = startRæk + 1 To slutRæk
        If Range("A" & ræk) = "" Then
            Exit For
        Else
            If Range("B" & ræk) = aktivitet Then
                til = Right(Range("A" & ræk), 5)
            Else
                visAktivitet redRæk
                redRæk = redRæk + 1
               
                opsætAktivitet ræk
            End If
        End If
    Next ræk
   
    visAktivitet redRæk
End Sub
Private Sub opsætAktivitet(ræk)
    interval = Range("A" & ræk)
    aktivitet = Range("B" & ræk)
    fra = Trim(Left(interval, 5))
    til = Trim(Right(interval, 5))
End Sub
Private Sub visAktivitet(ræk)
    Range("A" & ræk) = fra & "-" & til
    Range("B" & ræk) = aktivitet
End Sub

Kan sku ikke få et til at virke da jeg ikke er så god til makroer - ken jeg evt sende filen til dig og vil du så smide den ind ? :)

ok - @-adresse under min profil

Dim ark3 As Worksheet, arkSys As Worksheet

Const startRæk = 5
Dim antalRækker As Long
Dim ansvarlig As String, fra As Date, til As Date, lokale As String

Dim interval As String, aktivitet As String
Dim xRæk As Long
Sub lokaleOversigt()
    Set ark3 = ActiveWorkbook.Sheets("Ark3")
    Set arkSys = ActiveWorkbook.Sheets("LokaleOversigt")
   
    arkSys.Cells.Select
    Selection.ClearContents
    arkSys.Range("A1").Select
   
    ark3.Activate
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
   
    xRæk = 1
   
    opsætAktivitet startRæk
   
    For ræk = startRæk + 1 To antalRækker
        With ark3
            If .Range("A" & ræk) <> "" Then
                If .Range("A" & ræk) & .Range("D" & ræk) = ansvarlig & lokale Then
                    til = .Range("C" & ræk)
                Else
                    visAktivitet xRæk
                    xRæk = xRæk + 1
                   
                    opsætAktivitet ræk
                End If
            End If
        End With
    Next ræk
   
    visAktivitet xRæk
   
    arkSys.Activate
    arkSys.Columns.AutoFit
End Sub
Private Sub opsætAktivitet(ræk)
    With ark3
        ansvarlig = .Range("A" & ræk)
        fra = .Range("B" & ræk)
        til = .Range("C" & ræk)
        lokale = .Range("D" & ræk)
    End With
End Sub
Private Sub visAktivitet(ræk)
    With arkSys
        .Range("A" & ræk) = ansvarlig
        .Range("B" & ræk) = Format(fra, "hh:mm")
        .Range("C" & ræk) = Format(til, "hh:mm")
        .Range("D" & ræk) = lokale
    End With
End Sub