Versimpelen van de macro.....

[Theknurt]

Hallo mede exelisten,

Ik ben bezig met een macro, maar ik vroeg me af of deze te versimpelen en versnellen zou kunnen zijn.

Het is de bedoeling dat hij over 52 x 7 kolommen een dikke buitenrand plaatst en binnenin dunne lijnen.
Dit moet gebeuren over 16 lijnen.

Ik hoop dat jullie een simpeler en snellere oplossing weten te bereiken in deze.....

Sub WeekLijnen_Reset()

Dim I As Integer
Application.ScreenUpdating = False
  ActiveSheet.Range("B4").Select
 
        
    Range(ActiveCell.Offset(0, 0), ActiveCell.Offset(15, 6)).Select
    
    For I = 1 To 52
         
    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
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Range(ActiveCell.Offset(0, 13), ActiveCell.Offset(15, 7)).Select
    
    Next I
    
    ActiveCell.Select
Application.ScreenUpdating = True
End Sub

 

[Cobbe]

Wat overbodige troep er uit gelaten, zijn de cellen leeg als je deze macro draait? dan kan het eenvoudiger.
Trouwens als dit een eenmalige handeling zou zijn ben je beter af met een handmatige instelling:

Sub WeekLijnen_Reset()

Dim I As Integer
Application.ScreenUpdating = False
      
With Range("B4").Resize(16, 52)
    With Selection.Borders(xlInsideHorizontal)
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeLeft)
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .Weight = xlMedium
    End With
End with
Application.ScreenUpdating = True
End Sub

 

[Theknurt]

Hoi Cobbe,

Bedankt voor je snelle reactie, maar hij (schijnt) niet te werken. Er gebeurd althans niks...

De cellen zijn niet leeg als de macro gedraaid moet worden. Bij het kopiëren van data uit de cellen wordt vaak de lijnstructuur mee gekopieerd.
Hierdoor moeten soms de lijnen weer terug komen op de oorspronkelijke plaatsen.

Er zijn 52 (weken) blokken (blok= 7 dagen x 16 rijen) per groep en er zijn 5 groepen. Is handmatig wat veel werk om elke keer de lijnen te resetten........

Ik hoop dat er toch een oplossing gevonden kan worden.

 

[Cobbe]

Ja sorry, foutje dit werkt niet met End With maar enkel via selection, dus:

Sub WeekLijnen_Reset()

Dim I As Integer
Application.ScreenUpdating = False
      
Range("B4").Resize(16, 52).Select    'die 52 dien je aan te passen aan het aantal nodige kolommen (bv 52*7)
    With Selection.Borders(xlInsideHorizontal)
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeLeft)
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .Weight = xlMedium
    End With
End Sub

 

[Warme bakkertje]

Toch wel

Sub WeekLijnen_Reset()

    Application.ScreenUpdating = False
    With Range("B4").Resize(16, 52)    'die 52 dien je aan te passen aan het aantal nodige kolommen (bv 52*7)
        .Borders(xlInsideHorizontal).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround , xlMedium
    End With
    Application.ScreenUpdating = True
    
End Sub