الرجاء التعديل على هدا الكود

[ريان أحمد]

السلام عليكم الرجاء التعديل على جزئية الكود للخلية

d2

 

حت تنجح الفرز بالتاريخ

rr.rar

[الـعيدروس]

السلام عليكم

ضيف هذه الاسطر في حدث الورقة Worksheet_Change

If Range("D2").Value = "" Then
 ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=4
Else
Dim D_a As Date
 Dim Id&, Tr
 Tr = ActiveSheet.Range("D2")
  D_a = DateSerial(Year(Tr), Month(Tr), Day(Tr))
  Id = D_a
 ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=4, Criteria1:=Format$(Id, "yyyy/mm")
End If

[ريان أحمد]

السلام عليكم

 

أستاذي القدير قمت بالتعديل لكن لم ينجح الأمر

rr.rar

[ريان أحمد]

للرفع

[الـعيدروس]

السلام عليكم

بيكون الكود بعد التعديل كالتالي

انسخ والصقه في ملفك

والمرفق توضيح عمل الكود عندي

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, ActiveSheet.Rows(2)) Is Nothing Then
If ActiveSheet.AutoFilterMode Then
  ActiveSheet.Cells.AutoFilter
  Target.Interior.Color = RGB(255, 153, 0)
End If
Cancel = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

 If Range("f2").Value = "" Then
 ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=6
Else
 ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=6, Criteria1:=Range("f2")
End If

 If Range("g2").Value = "" Then
 ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=7
Else
 ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=7, Criteria1:=Range("g2")
End If

If Range("h2").Value = "" Then
 ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=8
Else
 ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=8, Criteria1:=Range("h2")
End If

  
If Range("i2").Value = "" Then
 ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=9
Else
 ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=9, Criteria1:=Range("i2")
End If

If Range("e2").Value = "" Then
 ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=5
Else
 ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=5, Criteria1:=Range("e2")
End If

If Range("D2").Value = "" Then
 ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=4
Else
Dim D_a As Date
 Dim Id&, Tr
 Tr = ActiveSheet.Range("D2")
  D_a = DateSerial(Year(Tr), Month(Tr), Day(Tr))
  Id = D_a
 ActiveSheet.Range("$A$2:$i$2500").AutoFilter Field:=4, Criteria1:=Format$(Id, "yyyy/mm")
 Target.Interior.Color = 255
End If

End Sub

تطبيق شرح.rar

[ريان أحمد]

شكرا أستاذي القدير وبارك الله فيك   الملف يعمل عندي بشكل جيد

 

-------------أستاذي هل يمكن نقل هذه الكود إل لا فورم بحيث يجلب البانات في ليس بوكس

[ريان أحمد]

للرفع

[الـعيدروس]

السلام عليكم

 

 

شاهد المرفقات

 

هذه كودك بعد الاختصار والتعديل

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, ActiveSheet.Rows(2)) Is Nothing Then
If ActiveSheet.AutoFilterMode Then
  Target.Interior.Color = RGB(255, 153, 0)
  Target.ClearContents
  ActiveSheet.Cells.AutoFilter
End If
Cancel = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A2:I2]) Is Nothing Then
Cc = Target.Column
If Target.Value = "" Then
 ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=Cc
 Else
  Tr = Target
  If IsDate(Tr) Then
  D_a = DateSerial(Year(Tr), Month(Tr), Day(Tr))
  Id = D_a
  Tr = Format$(Id, "yyyy/mm")
  End If
 ActiveSheet.Range("$A$3:$i$2500").AutoFilter Field:=Cc, Criteria1:=Tr
 List_Ali Feuil2.Range("$A$3")
 Exit Sub
End If
End If
End Sub
Private Sub List_Ali(Rng As Range)
Dim Ri As Range
Dim Ar&
Application.EnableEvents = 0
 Application.ScreenUpdating = 0
With Sheets("Feuil3")
        .UsedRange.Clear
       Set Ri = Rng.CurrentRegion.SpecialCells(xlCellTypeVisible)
         A = Cells(Rows.Count, 1).End(xlUp).Row
       Set Ri = Range(Ri.Offset(2, 0), Cells(A, 9))
       Ri.Copy .Range("A1")
        Set Ri = .Range("A1").CurrentRegion
        With UserForm1.ListBox1
            .ColumnCount = 9
            .List = Ri.Value
        End With
        UserForm1.Show
         .UsedRange.Clear
End With
 Application.EnableEvents = 1
Application.ScreenUpdating = 1
End Sub

شرح_2.rar

rrr_2.rar

تم تعديل سبتمبر 4, 2013 بواسطه عباد

[ريان أحمد]

Private Sub TextBox3_Change()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim lastrow As Long
lastrow = Range("b65535").End(xlUp).Row
If TextBox3.Text <> "" Then
    ActiveSheet.Range("$A$4:$v$" & lastrow).AutoFilter Field:=2, Criteria1:= _
    "=" & "*" & TextBox3.Text & "*", Operator:=xlOr
    Else
    ActiveSheet.Range("$A$4:$v$" & lastrow).AutoFilter Field:=2, Criteria1:= _
    "=" & "*" & TextBox3.Text & "*", Operator:=xlOr
    End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

 

 

يحتوي على حرف

 

 

----------------------------------------------------

 

 

Private Sub TextBox1_Change()

Dim lastrow As Long
lastrow = Range("b65535").End(xlUp).Row
If ActiveSheet.TextBox1.Text <> "" Then
        Selection.AutoFilter
    Range("$A$3:$v$" & lastrow).AutoFilter Field:=2, Criteria1:= _
        "=" & ActiveSheet.TextBox1.Text & "*", Operator:=xlOr
    Else
    Range("$A$1:$v$" & lastrow).AutoFilter Field:=2
    End If
End Sub

 

يبدأ بحرف مدخل في التكس بوكس

 

 

 

-------------------------

 

 

 

 

أستاذي العزيز بارك الله فيك وجزاك الله كل خير   على المساعدة وعلى هذه الردود السريعة

 

لكن الإدخال أريده من  الفورم في فثء لاخء مع لإضافة خاصية البحث مجرد إدخال حرف   بخاصيتين كما هو مبين في الكودين

 

 

وجزاك الله كل خير

[الـعيدروس]

ارى طلبك الاخير مختلف تمام

عن طلب تعديل كود

ارجو منك فتح موضوع جديد

وبه طلبك الاخير مع ارفاق مثال لذلك

وان وجد وقت لدي 

او احد الاخوة الافاضل 

والسلام عليكم