Celopmaak dmv dubbel klikken

[popipipo]

VBA is niet mijn sterkste kant vandaar de volgende vraag.

In een cel wil ik via dubbelklikken een diagonale streep krijgen.
Staat de diagonale streep er dan moet hij juist weer verdwijnen.(herstel van evt foutje)
Of (in een ander bereik) moet er juist een kruis verschijnen
en bij een derde keer dubbel klikken pas verdwijnen.

Hij loopt gedeeltelijk maar nog niet naar mijn zin.

 

[Ginger]

Willem, Kijk 'ns of je hier iets mee kan?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    
    If Not Intersect(Target, Range("B2:AA18")) Is Nothing And Target.Cells.Count = 1 Then
        If Target.Borders(xlDiagonalUp).LineStyle = xlNone Then
            Target.Borders(xlDiagonalUp).LineStyle = xlContinuous
        ElseIf Target.Borders(xlDiagonalDown).LineStyle = xlNone Then
            Target.Borders(xlDiagonalDown).LineStyle = xlContinuous
        Else
            With Target
                .Borders(xlDiagonalUp).LineStyle = xlNone
                .Borders(xlDiagonalDown).LineStyle = xlNone
            End With
        End If
        Target.Offset(0, 1).Select
    End If

End Sub

Zo ja, dan is de stap naar 1 codeblokje voor alle sheets zo gemaakt.

Groet, Leo

 

[snb]

Hiermee zou je een eind moeten kunnen komen:
Zet deze code in de module Thisworkbook, dan geldt ie voor alle werkbladen.

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  If InStr("345", Target.Column) > 0 Then
    With Target.Borders(6)
      If .LineStyle = xlLineStyleNone Then
        .LineStyle = 1
      ElseIf .LineStyle = 1 And Target.Borders(5).LineStyle = xlLineStyleNone Then
        Target.Borders(5).LineStyle = 1
      ElseIf .LineStyle + Target.Borders(5).LineStyle = 2 Then
        .LineStyle = xlLineStyleNone
        Target.Borders(5).LineStyle = xlLineStyleNone
      End If
    End With
    Target.Offset(, 1).Select
  End If
End Sub

 

[Ginger]

...dit is de kleine aanvulling om 'm in de ThisWorkbook-module te plaatsen... (vergeet dan niet ff je codeblokjes uit de sheet-modules te verwijderen)

Private Sub [COLOR="Blue"]Workbook_[/COLOR]SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    
        If Not Intersect(Target, [COLOR="blue"]Sh[/COLOR].Range("B2:AA18")) Is Nothing And Target.Cells.Count = 1 Then
            If Target.Borders(xlDiagonalUp).LineStyle = xlNone Then
                Target.Borders(xlDiagonalUp).LineStyle = xlContinuous
            ElseIf Target.Borders(xlDiagonalDown).LineStyle = xlNone Then
                Target.Borders(xlDiagonalDown).LineStyle = xlContinuous
            Else
                With Target
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                End With
            End If
            Target.Offset(0, 1).Select
        End If

End Sub

Groet, Leo

P.s. Nou snb, we zaten prima op één lijn nietwaar?

 

[snb]

@Ginger
Dat scheelt inderdaad geen haar.
'Vandaar' een alternatief

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  With Target
    If InStr("345", .Column) > 0 Then
      Select Case .Borders(6).LineStyle + .Borders(5).LineStyle
      Case -8284
        .Borders(6).LineStyle = 1
      Case -4141
        .Borders(5).LineStyle = 1
      Case 2
        .Borders(6).LineStyle = -4142
        .Borders(5).LineStyle = -4142
      End Select
      .Offset(, 1).Select
    End If
  End With
End Sub

 

[popipipo]

@snb
Door je formule werkt door het aan te passen van

  If InStr("345", .Column) > 0 Then

naar

If InStr("23456789101112131415161718192021222324252627", .Column) > 0 Then

@Leo
Jou formule werkt meteen
Wat ik echter wilde is:
cellen B2 tm AA2 achtereenvolgens schuine streep, kruis niets
cellen B3 tm AA18 achtereenvolgens schuinestreep en niets.

Ik heb de formule van Leo aangepast tot

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
        
        If Not Intersect(Target, Sh.Range("B1:AA1")) Is Nothing And Target.Cells.Count = 1 Then
            If Target.Borders(xlDiagonalUp).LineStyle = xlNone Then
                Target.Borders(xlDiagonalUp).LineStyle = xlContinuous
            ElseIf Target.Borders(xlDiagonalDown).LineStyle = xlNone Then
                Target.Borders(xlDiagonalDown).LineStyle = xlContinuous
            Else
                With Target
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                End With
            End If
            Target.Offset(0, 1).Select
        End If

        If Not Intersect(Target, Sh.Range("B2:AA18")) Is Nothing And Target.Cells.Count = 1 Then
            If Target.Borders(xlDiagonalUp).LineStyle = xlNone Then
                Target.Borders(xlDiagonalUp).LineStyle = xlContinuous
            'ElseIf Target.Borders(xlDiagonalDown).LineStyle = xlNone Then
            '    Target.Borders(xlDiagonalDown).LineStyle = xlContinuous
            Else
                With Target
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                End With
            End If
            Target.Offset(0, 1).Select
        End If

End Sub

Dit werkt uitstekend.
Heb ik dit goed gedaan of kan het nog korter?

 

[Ginger]

Heb ik dit goed gedaan of kan het nog korter?

Hmmm... Je spreekt jezelf wel tegen met...

Wat ik echter wilde is:
cellen B2 tm AA2 achtereenvolgens schuine streep, kruis niets
cellen B3 tm AA18 achtereenvolgens schuinestreep en niets.

...en...

If Not Intersect(Target, Sh.Range("B1:AA1")) Is Nothing And Target.Cells.Count = 1 Then
If Not Intersect(Target, Sh.Range("B2:AA18")) Is Nothing And Target.Cells.Count = 1 Then

Dus wellicht moet je die nog ff aanpassen, dan lijkt mij 't ok zo..

Groet, Leo

 

[popipipo]

Leo

Zéééééér oplettend van je.:thumb::thumb:
Mijn VBA code was goed, maar wat ik intikte wat ik wilde zat de fout.

 

[snb]

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  With Target
    If not intersect(target,sh.range("B1:AA18")) is nothing and .cells.count=1 then
      Select Case .Borders(6).LineStyle + .Borders(5).LineStyle
      Case -8284
        .Borders(6).LineStyle = 1
      Case -4141 
        if .row=1 then .Borders(5).LineStyle = 1
      Case 2
        .Borders(6).LineStyle = -4142
        .Borders(5).LineStyle = -4142
      End Select
      .Offset(, 1).Select
    End If
  End With
End Sub