دمج كودين vba بنفس الحدث في ورقة واحده

[أبو إسحاق]

السلام عليكم

طاب يومكم

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

فأردت أن أدمج كودين بنفس الحدث Worksheet_Change في نفس الشيت

الكود الأول يكتب تاريخ وقت التغيير في خلايا العمود w عندما يحدث هذا التغيير في الخلية المقابلة في العمود h

Private Sub Worksheet_Change(ByVal Target As Range)

Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("h4:h1000"), Target)
xOffsetColumn = 15
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
    For Each Rng In WorkRng
        If Not VBA.IsEmpty(Rng.Value) Then
            Rng.Offset(0, xOffsetColumn).Value = Now
            Rng.Offset(0, xOffsetColumn).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
        Else
            Rng.Offset(0, xOffsetColumn).ClearContents
        End If
    Next
    Application.EnableEvents = True
End If
End Sub

 

الكود الثاني يعمل على فرز التاريخ تصاعدي على حسب  التاريخ في خلايا العمود h
 

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range

Set Rng = Application.Intersect(Range("H3:H1000"), Range(Target.Address))
If Not Rng Is Nothing Then
  If Target.Column = 8 Then
  ActiveSheet.Unprotect officena
  Rng.Sort Key1:=Range("H4"), Order1:=xlAscending, _
  Header:=xlGuess, OrderCustom:=1
  End If
  ActiveSheet.Protect officena, AllowSorting:=True, AllowFiltering:=True
End If

End Sub

 

ولكم جزيل الشكر

 

 

my.xlsm

[علي حيدر]

تفضل اخي أبو اسحاق ارجو ات يكون المطلوب

my.xlsm

[أبو إسحاق]

مشكور أخوي علي:

بعد الدمج الكود يعمل

كانت هناك رسالة خطأ تظهر سببها مكان سطر فتح حماية الشيت

غيرت مكانه لبداية الكود ، الآن 100%

جزاك الله خير

 

تحياتي لك

 

 

[wahid-chaoui]

السلام عليكم ورحمة الله تعالى وبركاته

جربت دمج هذين الكودين ولم افلح

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

1 خاص بالورقة

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("d4")) Is Nothing Then
If [a2] = 1 Then
Application.ScreenUpdating = False
If Target.Text = "ãÈíÚÇÊ" Then  '---------------------------
 Range("H4").Validation.Delete
 Range("H4").Validation.Add Type:=xlValidateList, Formula1:="=seller"
 [d5] = Application.WorksheetFunction.Max(Sheet3.Range("b5:b10000")) + 1
End If
If Target.Text = "ãÔÊÑíÇÊ" Then
[a1] = 2
 Range("H4").Validation.Delete
 Range("H4").Validation.Add Type:=xlValidateList, Formula1:="=buyer"
  [d5] = Application.WorksheetFunction.Max(Sheet4.Range("b5:b10000")) + 1
End If
End If
If Target.Text = "ãÈíÚÇÊ" Then [a1] = 3
If Target.Text = "ãÔÊÑíÇÊ" Then [a1] = 2
End If
If Not Intersect(Target, Range("h4:i4")) Is Nothing Then
If Range("d4").Text = "ãÈíÚÇÊ" Then  '---------------------------
 Range("f5") = Application.WorksheetFunction.VLookup(Target, Sheet1.Range("q5:s5000"), 2, 0)
 Range("h5") = Application.WorksheetFunction.VLookup(Target, Sheet1.Range("q5:s5000"), 3, 0)
End If
If Range("d4").Text = "ãÔÊÑíÇÊ" Then  '---------------------------
 Range("f5") = Application.WorksheetFunction.VLookup(Target, Sheet1.Range("t5:v5000"), 2, 0)
 Range("h5") = Application.WorksheetFunction.VLookup(Target, Sheet1.Range("t5:v5000"), 3, 0)
End If
If [h4] = "" Then Range("f5") = ""
If [h4] = "" Then Range("h5") = ""

End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("e8:g32,b8:b32,f5,h5")) Is Nothing Then Cells(Target.Row, 1).Select
If Not Intersect(Target, Range("f4")) Is Nothing And [a2] = 1 Then UserForm1.Show
If Not Intersect(Target, Range("f4,h4")) Is Nothing And [a2] = 2 Then Cells(Target.Row, 1).Select
If Not Intersect(Target, Range("d5")) Is Nothing And [a2] = 1 Then Cells(Target.Row, 1).Select
End Sub

2 خاص بـ Combobox

Dim a(), mémo, f
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Set f = Sheets("Mar")
  Set zSaisie = Range("D12:D35")
  If Not Intersect(zSaisie, Target) Is Nothing And Target.Count = 1 Then
    If mémo <> "" Then If IsError(Application.Match(Range(mémo), a, 0)) Then Range(mémo) = ""
    a = Application.Transpose(f.Range("a2:a" & f.[A65000].End(xlUp).Row))
    Me.ComboBox1.List = a
    Me.ComboBox1.Height = Target.Height + 3
    Me.ComboBox1.Width = Target.Width
    Me.ComboBox1.Top = Target.Top
    Me.ComboBox1.Left = Target.Left
    Me.ComboBox1 = Target
    Me.ComboBox1.Visible = True
    Me.ComboBox1.Activate
    mémo = Target.Address
  Else
    Me.ComboBox1.Visible = False
  End If
End Sub
Private Sub ComboBox1_Change()
  If Me.ComboBox1 <> "" And IsError(Application.Match(Me.ComboBox1, a, 0)) Then
    Set d1 = CreateObject("Scripting.Dictionary")
    tmp = UCase(Me.ComboBox1) & "*"
    For Each c In a
      If UCase(c) Like tmp Then d1(c) = ""
    Next c
    Me.ComboBox1.List = d1.keys
    Me.ComboBox1.DropDown
  End If
  ActiveCell.Value = Me.ComboBox1
End Sub
Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  ComboBox1.List = Application.Transpose(f.Range("a2:a" & f.[A65000].End(xlUp).Row))
  Me.ComboBox1.DropDown
End Sub
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  If KeyCode = 13 Then
    If IsError(Application.Match(ActiveCell, a, 0)) Then ActiveCell = ""
    ActiveCell.Offset(1).Select
  End If
End Sub

 

facture.xls