اذهب الي المحتوي
أوفيسنا

دمج كودين 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

رابط هذا التعليق
شارك

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

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

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

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

جزاك الله خير

 

تحياتي لك

 

 

رابط هذا التعليق
شارك

  • 1 year later...

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

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

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

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

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information