دمج كودين

[jo0]

السلام عليكم 

اريد دمج الكودين الاتيين

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
       If Not Intersect(Target, Range("q9:q300")) Is Nothing Then
             If Target.Value = "a" Then Target.Offset(, -4).ClearContents
        End If
       If Not Intersect(Target, Range("r9:r300")) Is Nothing Then
             If Target.Value = "a" Then Target.Offset(, -6).ClearContents
        End If
       If Not Intersect(Target, Range("s9:s300")) Is Nothing Then
             If Target.Value = "a" Then Target.Offset(, -8).ClearContents
        End If
        If Not Intersect(Target, Range("t9:t300")) Is Nothing Then
             If Target.Value = "a" Then Target.Offset(, -10).ClearContents
        End If
        If Not Intersect(Target, Range("u9:u300")) Is Nothing Then
             If Target.Value = "a" Then Target.Offset(, -12).ClearContents
        End If
        If Not Intersect(Target, Range("v9:v300")) Is Nothing Then
             If Target.Value = "a" Then Target.Offset(, -14).ClearContents
        End If
        If Not Intersect(Target, Range("w9:w300")) Is Nothing Then
             If Target.Value = "a" Then Target.Offset(, -16).ClearContents
        End If
        If Not Intersect(Target, Range("x9:x300")) Is Nothing Then
             If Target.Value = "a" Then Target.Offset(, -18).ClearContents
        End If
        If Not Intersect(Target, Range("y9:y300")) Is Nothing Then
             If Target.Value = "a" Then Target.Offset(, -20).ClearContents
        End If
       
End Sub

مع الكود الثاني

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = "$g$3" And Target.Cells.Count = 1 Then
 Sheets("الحراسة").Range("$d$8") = Target
End If
Application.EnableEvents = True
End Sub

 

[سليم حاصبيا]

ربما هذا الكود

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Large_RG  As Range
Dim Unique_RG As Range
Dim Empty_String$, Other__String$
Dim Option_string$
Dim Position%
Const m = 2
Empty_String = "": Other__String$ = "Hirassa"
Set Large_RG = Range("Q9:Y300")
Set Unique_RG = Range("G3")
Dim q%, r%, S%, t%, u%, v%, W%, x%, y%
q = 17: r = 18: S = 19: t = 20
u = 21: v = 22: W = 23: x = 24: y = 25
 Application.EnableEvents = False
  If Not Intersect(Target, Unique_RG) Is Nothing _
    And Target.Cells.Count = 1 Then
    Range("D8") = Other__String
  End If
  
  If Not Intersect(Target, Large_RG) Is Nothing _
   And Target.Cells.Count = 1 Then
      Select Case Target.Column
      Case q: Option_string = Empty_String: Position = q - 2 * m
      Case r: Option_string = Empty_String: Position = r - 3 * m
      Case S: Option_string = Empty_String: Position = S - 4 * m
      Case t: Option_string = Empty_String: Position = t - 5 * m
      Case u: Option_string = Empty_String: Position = u - 6 * m
      Case v: Option_string = Empty_String: Position = v - 7 * m
      Case W: Option_string = Empty_String: Position = W - 8 * m
      Case x: Option_string = Empty_String: Position = x - 9 * m
      Case y: Option_string = Empty_String: Position = y - 10 * m
     End Select
     If Target = "a" Then
       Target.Offset(, Position) = Empty_String
      End If
   End If
     
 Application.EnableEvents = True
 
End Sub

الملف

 

Joe_code.xlsm

[jo0]

شكرا  ...لكن ليس  هذا

اريد فقط ان  يعمل  الكودين مع بعض  

فقط 

[سليم حاصبيا]

انهما يعملان مع بعض

[jo0]

الكود الاول يقوم بحذف اذا نقرت نقر مزدوج والثاني  يتعلق بقائمة منسدلة من ورقة اخرى اتحكم فيها من هذه الورقة

[سليم حاصبيا]

الكودين من نوع   Worksheet_Change(ByVal Target As Range)

فأين الدويل كليك

[jo0]

الكود الاول   اذا نقرت نقر مزدوج في  خلية يحذف خلية اخرى ..اما الثاني  فيتعلق بالتحكم بقائمة منسدلة من  ورقة اخرى

[سليم حاصبيا]

لو كان الكود يعمل على الدوبل كليك لكان عنوانه

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

وليس   Worksheet_Change(ByVal Target As Range)

 

 

[jo0]

الكود الاول  حذف محتوى خلية وفق شرط اما الثاني  للقائمة المنسدلة