formatering af celler i mindre database

Skal gerne forsøge at hjælpe.
hans.knudsensnabelamail.tele.dk

Er dit regneark et tidsstudie der skal data behandles eller et regneark der kan registrere tidsstudie data? Er tidsstudiet i 100 dele eller ttu? Arbejder selv med tidsstudier til hverdag, måske jeg kan være behjælpelig med et par tips og tricks

Const startRæk = 263                    'torsdag

Dim antalRæk As Long, ræk As Long, slutRæk
Dim kolA, kolE, kolD As Byte, kolF, kolG
Dim formel As String
Public Sub justerSkæreplaner()
On Error GoTo fejl

    Application.ScreenUpdating = False
Rem beregn sidste række
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
   
Rem traverser rækker
    For ræk = startRæk To antalRæk
        kolC = Range("C" & ræk).Value
        kolE = Range("E" & ræk).Value
        kolD = findAntalEværdier(ræk)
       
        If Range("B" & ræk).Value <> "" Then
            Range("D" & ræk).Value = kolD
            slutRæk = ræk + kolD - 1
            formel = "=E" & CStr(slutRæk) & "- C" & CStr(ræk)
            Range("F" & ræk).Formula = formel
           
    Rem check om fejl
            If InStr(Range("F" & ræk), "-") = 1 Then
                Range("F" & ræk).Value = "Ugyldig tid"
            End If
           
    Rem flet celler hvis mere end 1
            If kolD > 1 Then
                Range("C" & ræk & ":C" & slutRæk).Select
                Selection.MergeCells = True
                Selection.VerticalAlignment = xlCenter
           
                Range("D" & ræk & ":D" & slutRæk).Select
                Selection.MergeCells = True
                Selection.VerticalAlignment = xlCenter
   
                Range("F" & ræk & ":F" & slutRæk).Select
                Selection.MergeCells = True
            End If
        Else
            kolD = 1
           
        End If
       
        AfsætRammestreger "B" & CStr(ræk) & ":V" & CStr(slutRæk)
       
Rem juster næste række, der skal behandles
        ræk = ræk + kolD - 1
    Next ræk
   
    Application.ScreenUpdating = True
   
    MsgBox "Justering afsluttet"
    Exit Sub
   
fejl:
    Stop
    Resume Next
End Sub
Private Function findAntalEværdier(ræk As Long)
Dim r As Long, antal As Long, flag As Boolean
    flag = False
    antal = 0
   
    For r = ræk To antalRæk
        If Range("C" & r).Value <> "" Then
            If flag = True Then
                findAntalEværdier = antal
                Exit Function
            End If
            antal = antal + 1
            flag = True
        Else
            antal = antal + 1
        End If
    Next r
   
    findAntalEværdier = antal
End Function
Private Sub AfsætRammestreger(område)
    Range(område).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub

1000 tak for hjælpen. Det har virkeligt betydet meget og gjort min arbejdsprocess meget nemmere :)

Selv tak - held og lykke med det...

Må jeg lave lidt reklame for din virksomhed i mit projekt ? hvor jeg refere til din hjemmeside.

Ja - du skal være velkommen (har først set det nu)