Please help get double click on cell

S

salehzi

New Member
Joined
Aug 5, 2023
Messages
7
Office Version
  1. 365
Platform
  1. Windows
عندما أنقر مرتين على خلية فارغة ، تظهر لي كلمة "الحاضر" باللون الأخضر ، وعندما أنقر مرتين على خلية فارغة أخرى ، أحصل على كلمة "غائب" باللون الأصفر.
عند النقر مرة أخرى على نفس الخلية يجعلها فارغة
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Sort by date Sort by votes
مرحبا بك في المنتدى وان كان ينبغي لك أن تطرح سؤالك هذا في منتدى اللغات الأخرى
لأجل التوضيح أكثر فقط، ما هي عناوين الخلايا المعنية بالأمر ؟
بالنسبة للخلية التي تودّ أن تكون فارغة، هل تقصد نقرة واحدة أم نقرتين؟
 
Upvote 1
Solution
Jaafar Tribak said:
ينبغي لك أن تطرح سؤالك هذا في منتدى اللغات الأخرى
البحث عن عناوين البريد الإلكتروني عناوين البريد الإلكتروني؟
بالنسبة للخلية التي تودّ أن تكون فارغة ، هل نقصد نقرة واحدة أم نقرتين؟
Click to expand...
اهلاً فيك وشكراً على توجيهك
ما اريده هو عندما انقر نقرة واحدة على الخلية تعطيني كلمة حاضر
وعندما انقر نقرتين على الخلية تعطيني غائب
وتحديد لون لكل خلية
 
Upvote 0
salehzi صباح الخير

ليس من السهل على الإطلاق التمييز بين النقرة والنقرة المزدوجة.
جرب هذا وانظر كيف ستسير الامور.
يفترض الكود أن الورقة المستهدفة هي الورقة 1 والخلية المستهدفة هي الخلية أ-1(Sheet1!A1)

ملف للتحميل
salehzi.xlsm


يجب وضع الكود في الموديول ThisWorkbook Module
VBA Code: 
Option Explicit

Private WithEvents CbBarsEvents As CommandBars

Private Type POINTAPI
    X As Long
    y As Long
End Type
 
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongPtr
    #Else
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    Private Declare PtrSafe Function GetDoubleClickTime Lib "user32" () As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function GetDoubleClickTime Lib "user32" () As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If

Private Const TARGET_RANGE_ADDRESS = "A1"    '<== Change target cell addr to suit.
Private Const TARGET_SHEET_NAME = "Sheet1"   '<== Change target sheet name to suit.

Private Sub Workbook_Activate()
    Call SetHook(True)
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call SetHook(False)
End Sub

Private Sub SetHook(ByVal bHook As Boolean)
    If bHook Then
        Set CbBarsEvents = Application.CommandBars
    Else
        Set CbBarsEvents = Nothing
    End If
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If LCase(Sh.Name) <> LCase(TARGET_SHEET_NAME) Then Exit Sub
    If CbBarsEvents Is Nothing Then
        Call SetHook(True)
    End If
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If LCase(Sh.Name) <> LCase(TARGET_SHEET_NAME) Then Exit Sub
    If Target.Address(0&, 0&) = Range(TARGET_RANGE_ADDRESS).Address(0&, 0&) Then
        Cancel = True
        With Target
            .Font.Bold = True
            .Font.Color = vbRed
            .Interior.Color = vbYellow
            .Value = ChrW(1594&) & ChrW(1575&) & ChrW(1574&) & ChrW(1576&)
        End With
    End If
End Sub

Private Sub CbBarsEvents_OnUpdate()
    #If VBA7 Then
        Static lPrevTickCount As LongPtr
    #Else
        Static lPrevTickCount As Long
    #End If
    Dim tCurPos As POINTAPI
    Dim obj As Object
    Dim sText1 As String, sText2 As String
 
    sText1 = ChrW(160&) & ChrW(1581&) & ChrW(1575&) & ChrW(1590&) & ChrW(1585&)
    sText2 = ChrW(1594&) & ChrW(1575&) & ChrW(1574&) & ChrW(1576&)
    If LCase(ActiveSheet.Name) <> LCase(TARGET_SHEET_NAME) Then Exit Sub
    If IsNavigKey Then
        GoTo Xit
    End If
    With ActiveCell
        If IsDelKey Then
            .Font.Bold = False
            .Font.ColorIndex = 0&
            .Interior.ColorIndex = 0&
            GoTo Xit
        End If
        Call GetCursorPos(tCurPos)
        Set obj = ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.y)
        If TypeName(obj) = "Range" Then
            If .Address(0&, 0&) = Range(TARGET_RANGE_ADDRESS).Address(0&, 0&) Then
                If GetTickCount - lPrevTickCount > GetDoubleClickTime Then
                    With ActiveCell
                        .Font.Bold = True
                        .Font.Color = vbGreen
                        .Interior.Color = vbBlue
                        .Value = sText1
                    End With
                End If
            End If
        End If
    End With
Xit:
    lPrevTickCount = GetTickCount
End Sub

Private Function IsDelKey() As Boolean
    If GetAsyncKeyState(vbKeyDelete) Then IsDelKey = True
End Function

Private Function IsNavigKey() As Boolean
    Dim vKeysArray As Variant, vKey As Variant
    vKeysArray = Array( _
        vbKeyReturn, _
        vbKeyTab, _
        vbKeyDown, _
        vbKeyUp, _
        vbKeyLeft, _
        vbKeyRight, _
        vbKeyHome, _
        vbKeyPageUp, _
        vbKeyPageDown, _
        vbKeyEnd _
    )
    For Each vKey In vKeysArray
        If GetAsyncKeyState(vKey) Then IsNavigKey = True
    Next vKey
End Function

In case a non-arabic speaker is interested and wants to know what the code above does, it distinguishes between Clicking and Double-Clicking a target cell ( Sheet1!A1),.
The target cell is formatted & assigned a specific value according to whether the cell was clicked or double-clicked.

The entire code goes in the ThisWorkbook Module.

The code doesn't rely on the Selection_Change event because it fires when selecting cells with the keyboard... The code should only fire when selecting with the mouse.
 
Upvote 1
Jaafar Tribak said:
salehzi صباح الخير

ليس من السهل على الإطلاق التمييز بين النقرة والنقرة المزدوجة.
جرب هذا وانظر كيف ستسير الامور.
يفترض الكود أن الورقة المستهدفة هي الورقة 1 والخلية المستهدفة هي الخلية أ-1(Sheet1!A1)

ملف للتحميل
salehzi.xlsm


يجب وضع الكود في الموديول ThisWorkbook Module
VBA Code: 
Option Explicit

Private WithEvents CbBarsEvents As CommandBars

Private Type POINTAPI
    X As Long
    y As Long
End Type
 
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongPtr
    #Else
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    Private Declare PtrSafe Function GetDoubleClickTime Lib "user32" () As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function GetDoubleClickTime Lib "user32" () As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If

Private Const TARGET_RANGE_ADDRESS = "A1"    '<== Change target cell addr to suit.
Private Const TARGET_SHEET_NAME = "Sheet1"   '<== Change target sheet name to suit.

Private Sub Workbook_Activate()
    Call SetHook(True)
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call SetHook(False)
End Sub

Private Sub SetHook(ByVal bHook As Boolean)
    If bHook Then
        Set CbBarsEvents = Application.CommandBars
    Else
        Set CbBarsEvents = Nothing
    End If
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If LCase(Sh.Name) <> LCase(TARGET_SHEET_NAME) Then Exit Sub
    If CbBarsEvents Is Nothing Then
        Call SetHook(True)
    End If
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If LCase(Sh.Name) <> LCase(TARGET_SHEET_NAME) Then Exit Sub
    If Target.Address(0&, 0&) = Range(TARGET_RANGE_ADDRESS).Address(0&, 0&) Then
        Cancel = True
        With Target
            .Font.Bold = True
            .Font.Color = vbRed
            .Interior.Color = vbYellow
            .Value = ChrW(1594&) & ChrW(1575&) & ChrW(1574&) & ChrW(1576&)
        End With
    End If
End Sub

Private Sub CbBarsEvents_OnUpdate()
    #If VBA7 Then
        Static lPrevTickCount As LongPtr
    #Else
        Static lPrevTickCount As Long
    #End If
    Dim tCurPos As POINTAPI
    Dim obj As Object
    Dim sText1 As String, sText2 As String
 
    sText1 = ChrW(160&) & ChrW(1581&) & ChrW(1575&) & ChrW(1590&) & ChrW(1585&)
    sText2 = ChrW(1594&) & ChrW(1575&) & ChrW(1574&) & ChrW(1576&)
    If LCase(ActiveSheet.Name) <> LCase(TARGET_SHEET_NAME) Then Exit Sub
    If IsNavigKey Then
        GoTo Xit
    End If
    With ActiveCell
        If IsDelKey Then
            .Font.Bold = False
            .Font.ColorIndex = 0&
            .Interior.ColorIndex = 0&
            GoTo Xit
        End If
        Call GetCursorPos(tCurPos)
        Set obj = ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.y)
        If TypeName(obj) = "Range" Then
            If .Address(0&, 0&) = Range(TARGET_RANGE_ADDRESS).Address(0&, 0&) Then
                If GetTickCount - lPrevTickCount > GetDoubleClickTime Then
                    With ActiveCell
                        .Font.Bold = True
                        .Font.Color = vbGreen
                        .Interior.Color = vbBlue
                        .Value = sText1
                    End With
                End If
            End If
        End If
    End With
Xit:
    lPrevTickCount = GetTickCount
End Sub

Private Function IsDelKey() As Boolean
    If GetAsyncKeyState(vbKeyDelete) Then IsDelKey = True
End Function

Private Function IsNavigKey() As Boolean
    خافت vKeysArray كمتغير ، vKey كمتغير
    vKeysArray = صفيف (_
        vbKeyReturn _
        vbKeyTab ، _
        vbKeyDown ، _
        vbKeyUp ، _
        vbKeyLeft ، _
        vbKeyRight ، _
        vbKeyHome ، _
        vbKeyPageUp ، _
        vbKeyPageDown ، _
        vbKeyEnd _
    )
    لكل vKey في vKeysArray
        إذا كان GetAsyncKeyState (vKey) ، فإن IsNavigKey = True
    التالي vKey
وظيفة النهاية
[/شفرة]

إذا كان المتحدث غير العربي مهتمًا ويرغب في معرفة ما يفعله الكود أعلاه ، فإنه يميز بين النقر والنقر المزدوج على خلية مستهدفة (Sheet1! A1) ،.
يتم تنسيق الخلية المستهدفة وتعيين قيمة محددة وفقًا لما إذا تم النقر فوق الخلية أو النقر نقرًا مزدوجًا عليها.

يذهب الكود بأكمله في [U]وحدة ThisWorkbook Module[/U] .

لا يعتمد الرمز على حدث Selection_Change لأنه يتم تنشيطه عند تحديد الخلايا باستخدام لوحة المفاتيح ... يجب تنشيط الرمز فقط عند التحديد باستخدام الماوس.
[/QUOTE]
حدثت مشكلة 
[ATTACH type="full"]96669[/ATTACH]
Click to expand...
 

Attachments

  • 1691382280978.png
    1691382280978.png
    83.1 KB · Views: 7
Upvote 0
Jaafar Tribak said:
salehzi صباح الخير

ليس من السهل على الإطلاق التمييز بين النقرة والنقرة المزدوجة.
جرب هذا وانظر كيف ستسير الامور.
يفترض الكود أن الورقة المستهدفة هي الورقة 1 والخلية المستهدفة هي الخلية أ-1(Sheet1!A1)

ملف للتحميل
salehzi.xlsm


يجب وضع الكود في الموديول ThisWorkbook Module
VBA Code: 
Option Explicit

Private WithEvents CbBarsEvents As CommandBars

Private Type POINTAPI
    X As Long
    y As Long
End Type
 
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongPtr
    #Else
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
    #End If
    Private Declare PtrSafe Function GetDoubleClickTime Lib "user32" () As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Declare Function GetDoubleClickTime Lib "user32" () As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If

Private Const TARGET_RANGE_ADDRESS = "A1"    '<== Change target cell addr to suit.
Private Const TARGET_SHEET_NAME = "Sheet1"   '<== Change target sheet name to suit.

Private Sub Workbook_Activate()
    Call SetHook(True)
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call SetHook(False)
End Sub

Private Sub SetHook(ByVal bHook As Boolean)
    If bHook Then
        Set CbBarsEvents = Application.CommandBars
    Else
        Set CbBarsEvents = Nothing
    End If
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If LCase(Sh.Name) <> LCase(TARGET_SHEET_NAME) Then Exit Sub
    If CbBarsEvents Is Nothing Then
        Call SetHook(True)
    End If
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If LCase(Sh.Name) <> LCase(TARGET_SHEET_NAME) Then Exit Sub
    If Target.Address(0&, 0&) = Range(TARGET_RANGE_ADDRESS).Address(0&, 0&) Then
        Cancel = True
        With Target
            .Font.Bold = True
            .Font.Color = vbRed
            .Interior.Color = vbYellow
            .Value = ChrW(1594&) & ChrW(1575&) & ChrW(1574&) & ChrW(1576&)
        End With
    End If
End Sub

Private Sub CbBarsEvents_OnUpdate()
    #If VBA7 Then
        Static lPrevTickCount As LongPtr
    #Else
        Static lPrevTickCount As Long
    #End If
    Dim tCurPos As POINTAPI
    Dim obj As Object
    Dim sText1 As String, sText2 As String
 
    sText1 = ChrW(160&) & ChrW(1581&) & ChrW(1575&) & ChrW(1590&) & ChrW(1585&)
    sText2 = ChrW(1594&) & ChrW(1575&) & ChrW(1574&) & ChrW(1576&)
    If LCase(ActiveSheet.Name) <> LCase(TARGET_SHEET_NAME) Then Exit Sub
    If IsNavigKey Then
        GoTo Xit
    End If
    With ActiveCell
        If IsDelKey Then
            .Font.Bold = False
            .Font.ColorIndex = 0&
            .Interior.ColorIndex = 0&
            GoTo Xit
        إنهاء إذا
        استدعاء GetCursorPos (tCurPos)
        قم بتعيين obj = ActiveWindow.RangeFromPoint (tCurPos.X، tCurPos.y)
        إذا كان TypeName (obj) = "Range" إذن
            If .Address (0 &، 0 &) = Range (TARGET_RANGE_ADDRESS). Address (0 &، 0 &) ثم
                إذا GetTickCount - lPrevTickCount> GetDoubleClickTime ثم
                    مع ActiveCell
                        .Font.Bold = صحيح
                        .Font.Color = vbGreen
                        الداخلية.اللون = vbBlue
                        .Value = sText1
                    انتهت ب
                إنهاء إذا
            إنهاء إذا
        إنهاء إذا
    انتهت ب
Xit:
    lPrevTickCount = GetTickCount
End Sub

الوظيفة الخاصة IsDelKey () كـ Boolean
    إذا GetAsyncKeyState (vbKeyDelete) ثم IsDelKey = True
وظيفة النهاية

الوظيفة الخاصة IsNavigKey () كـ Boolean
    خافت vKeysArray كمتغير ، vKey كمتغير
    vKeysArray = صفيف (_
        vbKeyReturn _
        vbKeyTab ، _
        vbKeyDown ، _
        vbKeyUp ، _
        vbKeyLeft ، _
        vbKeyRight ، _
        vbKeyHome ، _
        vbKeyPageUp ، _
        vbKeyPageDown ، _
        vbKeyEnd _
    )
    لكل vKey في vKeysArray
        إذا كان GetAsyncKeyState (vKey) ، فإن IsNavigKey = True
    التالي vKey
وظيفة النهاية
[/شفرة]

إذا كان المتحدث غير العربي مهتمًا ويرغب في معرفة ما يفعله الكود أعلاه ، فإنه يميز بين النقر والنقر المزدوج على خلية مستهدفة (Sheet1! A1) ،.
يتم تنسيق الخلية المستهدفة وتعيين قيمة محددة وفقًا لما إذا تم النقر فوق الخلية أو النقر نقرًا مزدوجًا عليها.

يذهب الكود بأكمله في [U]وحدة ThisWorkbook Module[/U] .

لا يعتمد الرمز على حدث Selection_Change لأنه يتم تنشيطه عند تحديد الخلايا باستخدام لوحة المفاتيح ... يجب تنشيط الرمز فقط عند التحديد باستخدام الماوس.
[/QUOTE]
شكرا لك 
الكود يعمل بنجاح 
هذا ما اردت الوصول له 
رااااائع
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Solved
Double click to copy a cell to the next empty cell in a different column and sheet (VBA code)
Replies
3
Views
317
kevin9999
K
M
  • Question
Double click navigating to referenced cells
Replies
1
Views
213
6StringJazzer
6StringJazzer
H
  • Solved
Double Click Cell to cell to Sheet Name and Cell
2
Replies
11
Views
471
howard
H
N
  • Question
Double Click Macro that creates new sheet using SQL query
Replies
1
Views
148
Fluff
Fluff
F
  • Solved
Double click and jump to another sheet with the same data
2
Replies
11
Views
601
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,215,573
Messages
6,125,608
Members
449,238
Latest member
wcbyers

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top