Error Before Double Click function

[Vincent88]

Hi Guys,
My code does not work on those weekend columns. Please help to review where goes wrong.
When double click a blank cell, it will be filled with pattern. If it is already filled with pattern, it will change the cell to a blank cell. However it does not work on those weekend columns. I have a function IsWeekend.

TestDropDownList_2.xlsm
	A	B						H	I	J	K	L	M	N	O
1	MDate	Attendance						1-Feb	2-Feb	3-Feb	4-Feb	5-Feb	6-Feb	7-Feb	8-Feb
2	Date	Summary						1	2	3	4	5	6	7	8
3	Larry Q	T:16 L:0.5 D:2.5 E:0 N:0						G	G	G	D	N		D1	D3
4	Mandy H	T:16 L:0.5 D:3.5 E:0 N:0						D	K		D	K	K	K
5	John G	T:16 L:0 D:1 E:2 N:0						D
6	Zita V	T:16 L:1 D:2 E:0 N:1													g
7	Peter B	T:16 L:2 D:1 E:0 N:0								AL
8	Nacy L	T:16 L:0 D:3 E:0 N:2						D	G	N	N		D
202202

Cells with Data Validation
Cell	Allow	Criteria
A2	List	=Data!$P$2:$P14
A3	List	=Data!$P$2:$P$14
A4	List	=Data!$P$2:$P$13
A5:A6	List	=Data!$P$2:$P$12
A7	List	=Data!$P$2:$P$11
A8	List	=Data!$P$2:$P$10

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Sh.Name = "Data" Then Exit Sub

On Error Resume Next

Dim lr As Long
Dim Lc As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
Dim rngArea As Range
Set rngArea = Range(Cells(3, 8), Cells(lr, Lc))


Debug.Print rngArea.Address

If Not Intersect(Target, rngArea) Is Nothing Then
   Cancel = True
   If Not IsEmpty(Target.Value) Then Exit Sub
 
      If Target.Interior.Pattern = xlNone = True Then
                   With Target.Interior
                     .Pattern = xlPatternUp
                     .PatternColor = RGB(166, 166, 166)
                   End With
   
      Else
       If Target.Interior.Pattern = xlNone = False Then
             If IsWeekend(Cells(1, Target.Column)) = False Then
                    Target.Interior.Pattern = xlNone
                 
             Else
                If IsWeekend(Cells(1, Target.Column)) = True Then
                      Target.Interior.Pattern = xlNone
                      Target.Interior.Color = RGB(255, 245, 230)
                End If
             End If
       End If
      End If
 
End If
   
End Sub


Public Function IsWeekend(InputDate As Date) As Boolean
 
        Select Case Weekday(InputDate)
        Case vbSaturday, vbSunday
            IsWeekend = True
        Case Else
            IsWeekend = False
    End Select
   
End Function

 

[Joe4]

Your code for the weekend dates is doing different things than your other code is.
How exactly do you want the weekend dates to react?

 

[Vincent88]

Hi Joe4,
Same as other normal cells. If the cell is in the weekend column and is empty, double click trigger it to become patterned; if it is already patterned, then it becomes non patterned but interior color as the whole column.

 

[Joe4]

See if this does what you want:

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Sh.Name = "Data" Then Exit Sub

On Error Resume Next

Dim lr As Long
Dim Lc As Long
Dim rngArea As Range
Dim wkend As Boolean
Dim pat As Double

lr = Range("A" & Rows.Count).End(xlUp).Row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column

Set rngArea = Range(Cells(3, 8), Cells(lr, Lc))

Debug.Print rngArea.Address

If Not Intersect(Target, rngArea) Is Nothing Then
    Cancel = True
    If Not IsEmpty(Target.Value) Then Exit Sub
 
'   Get interior pattern number
    pat = Target.Interior.Pattern
    
'   Check to see if weekend
    wkend = IsWeekend(Cells(1, Target.Column))
    
'   Check to see if it has no lined pattern at all
    If (pat = -4142) Or (pat = 1) Then
        Target.Interior.Pattern = xlPatternUp
        Target.Interior.PatternColor = RGB(166, 166, 166)
    Else

'       Check to see if it has lined pattern
        If pat = -4162 Then
'           Check to see if weekend
            If wkend = True Then
                Target.Interior.Pattern = xlNone
                Target.Interior.Color = RGB(255, 245, 230)
            Else
                Target.Interior.Pattern = xlNone
            End If
        End If
    End If
        
End If
   
End Sub

 

[Vincent88]

Hi Joe4, Thanks. It works.

 

[Joe4]

You are welcome.

 

[Vincent88]

Hi Joe4, Need help from you.
I enchanced the code to copy from non-empty cell to four adjacent cells. I have already encoded to paste cells except patterned and non empty only but it does not copy to the weekend cells (with color RGB(255,245,230). Please advise where goes wrong ?

Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
    If sh.Name = "Data" Then Exit Sub
   
    Application.ScreenUpdating = False
    'Application.EnableEvents = False
   


On Error Resume Next

Dim lrow As Long
Dim Lcol As Long
Dim rngArea As Range
Dim wkend As Boolean
Dim pat As Double

lrow = Range("A" & Rows.Count).End(xlUp).Row
Lcol = Cells(1, Columns.Count).End(xlToLeft).Column

Set rngArea = Range(Cells(3, 8), Cells(lrow, Lcol))

Debug.Print rngArea.Address

If Not Intersect(Target, rngArea) Is Nothing Then
    Cancel = True
    If Not IsEmpty(Target.Value) Then                        
      'Target.Offset(, 1).Resize(, 4).Value = Target.Value
      For col4 = 1 To 4
           Dim adjcell As Range
           Set adjcell = Target.Offset(, col4)
           adjcellpat = Target.Offset(, col4).Interior.Pattern
           adjcellcol = Target.Offset(, col4).Interior.Color
           If adjcellpat <> -4142 Then                                'Cells with any pattern
               
                [COLOR=rgb(226, 80, 65)]ElseIf Target.Offset(, col4).Interior.Color = RGB(255, 245, 230) Then
                       Target.Offset(, col4).Value = Target.Value[/COLOR]
                                       
                ElseIf adjcell.Interior.Color = 16777215 And adjcell.Value = "" And adjcell.Interior.Pattern = xlNone Then
                       Target.Offset(, col4).Value = Target.Value      'Workable
                     
               
           Else
           End If
      Next col4
     
     
     
     
    Else
'ON/OFF FORMATTING CELLS TO PATTERN
'https://www.mrexcel.com/board/threads/error-before-double-click-function.1185307/#post-5774690
'Post 4 Joe4
   
   
'   Get interior pattern number
    pat = Target.Interior.Pattern
   
'   Check to see if weekend
    wkend = IsWeekend(Cells(1, Target.Column))
   
    '   Check to see if it has no lined pattern at all
        'pattern -4142 = xlPatternNone  and pattern 1 = xlPatternSolid
        If (pat = -4142) Or (pat = 1) Then
            Target.Interior.Pattern = xlPatternUp               ' or xlPatternLightVertical
            Target.Interior.PatternColor = RGB(166, 166, 166)
        Else
   
    '       Check to see if it has lined pattern
            'If pat = -4162 Then               'Pattern -4162 = xlPatternUp only
            If Not IsEmpty(pat) Then           'Applicable to any pattern
    '           Check to see if weekend
                If wkend = True Then
                    Target.Interior.Pattern = xlNone
                    Target.Interior.Color = RGB(255, 245, 230)
                Else
                    Target.Interior.Pattern = xlNone
                End If
            End If
        End If
    End If
End If

TestDropDownList_3.xlsm
	A	B						H	I	J	K	L	M	N	O	P	Q	R	S	T
1	MDate	Attendance						1-Feb	2-Feb	3-Feb	4-Feb	5-Feb	6-Feb	7-Feb	8-Feb	9-Feb	10-Feb	11-Feb	12-Feb	13-Feb
2	Date	Summary						1	2	3	4	5	6	7	8	9	10	11	12	13
3	Larry Q	T:16 L:0.5 D:2.5 E:0 N:0						G	G	G	D				D
4	Mandy H	T:16 L:0.5 D:3.5 E:0 N:0						D	K		K			D	K
5	John G	T:16 L:0 D:1 E:2 N:0						D
202202

Cells with Data Validation
Cell	Allow	Criteria
A2	List	=Data!$P$2:$P14
A3	List	=Data!$P$2:$P$14
A4	List	=Data!$P$2:$P$13
A5:A6	List	=Data!$P$2:$P$12

 

[Joe4]

Hi Joe4, Need help from you.
I enchanced the code to copy from non-empty cell to four adjacent cells. I have already encoded to paste cells except patterned and non empty only but it does not copy to the weekend cells (with color RGB(255,245,230). Please advise where goes wrong ?

That is a new twist on the question, and should probably be posted to a new thread (especially I will not have a chance to look at it today).

 

[Vincent88]

Hi Joe4, I created a new thread already.

Double click function not perform

Hi Guys, My code is to copy a cell value to its four adjacent cells. I have already encoded to paste cells except those patterned and non empty cells but it does not copy the value to the weekend cells with color RGB(255,245,230. Please advise where goes wrong ...

www.mrexcel.com