الغاء الفلتر من الملف

[mohamedyousef]

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

السادة الافاضل محتاج تغير بسيط في الكود المرسل حيث اريد عند الانتهاء من الطباعة الغي مرة اخرى الفلترة من على الملف حيث عند اختيار صنف معين للطباعة يقوم بعمل فلترة على الملف وعند الانتهاء من الطباعة واريد ان ابحث مرة اخري عن اي صنف اخر لاياتي ببيانات نظرا للفترة الموجودة على الملف فانا اريد عند الانتهاء من الطباعة كود من خلاله يتم الغاء الفلترة من الملف ويرجع مرة اخرى عند طباعة اي صنف اخر 

 

Private Sub CommandButton1_Click()
Dim LRow As Long
Dim namsh As String
Dim wk, wk2 As Worksheet
Dim x As Integer
Dim check As Boolean
namsh = "temp"
Set wk = Worksheets("التكويد")

'التأكد من عدم وجود الورقة المؤقته وإضافتها
For Each wk2 In Worksheets
If wk2.Name Like namsh Then check = True: Exit For
Next
If check = False Then
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = namsh
End With
End If
'ترحيل الصفوف المختارة
Set wk2 = Worksheets(namsh)
wk2.Range("A1:E9999") = ""
LRow = wk.Range("A999").End(xlUp).Row
wk.Range("A1:A" & LRow & ",E1:E" & LRow & ",R1:R" & LRow & ",S1:S" & LRow & ",T1:T" & LRow).Copy wk2.Range("A1")
With wk2
'إضافة المجاميع في الصف الأخير
Rowz = Application.WorksheetFunction.Subtotal(2, .Range("A2:A" & Rows(Rows.Count).End(xlUp).Row))
.Range("B" & Rowz + 2) = "الاجمالي"
.Range("C" & Rowz + 2) = "=ROUND(SUM(C2:C" & Rowz + 1 & "),2)"
.Range("D" & Rowz + 2) = "=ROUND(SUM(D2:D" & Rowz + 1 & "),2)"
.Range("E" & Rowz + 2) = "=ROUND(SUM(E2:E" & Rowz + 1 & "),2)"
.Columns("A:E").AutoFit
'تنسيق الصف الأخير الخاص بالمجموع
'

With wk2.Range("B" & Rowz + 2 & ":E" & Rowz + 2)
.AddIndent = True
.Font.FontStyle = "Times New Roman"
.Font.Size = 16
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Interior.Color = RGB(237, 237, 220)
.Font.Bold = False
.Font.Bold = True
End With
.PageSetup.PrintArea = "A1:E" & Rowz + 2 'LRow
Application.Dialogs(xlDialogPrint).Show
End With
'

Application.DisplayAlerts = False
'التأكد من وجود الورقة المؤقته وحذفها
If ThisWorkbook.Worksheets.Count = 1 Then MsgBox "There Is only One Sheet. The Deletion Can't Be Done!", vbCritical: Exit Sub
If Evaluate("=ISREF('" & namsh & "'!A1)") Then
Sheets(namsh).Delete
End If
Application.DisplayAlerts = True
End Sub
'عمل فلتر على محتوى الكمبوبوكس
Private Sub CommandButton2_Click()
With Worksheets("التكويد").Range("A1:T1")
'إلغاء الفلتر
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
If Me.ComboBox1.Text = "" Then Exit Sub
.AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Text '& "*"
End With
'استدعاء الطباعة
Call CommandButton1_Click
'إلغاء الفلتر
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
End Sub
'ملء الكمبوبوكس بأسماء السلع بعد حذف التكرار
Private Sub UserForm_Activate()
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
Dim wk As Worksheet
Set wk = Worksheets("التكويد")
Dim v, e
LRow = wk.Range("A999").End(xlUp).Row
v = wk.Range("C2:C" & LRow).Value
With CreateObject("scripting.dictionary")
.comparemode = 1
For Each e In v
If Not .exists(e) Then .Add e, Nothing
Next
If .Count Then Me.ComboBox1.List = Application.Transpose(.keys)
End With
End Sub

 

[ابا اسماعيل]

 بهذا الشكل، سيتم إلغاء عملية تصفية البيانات بعد الطباعة وسيعود الجدول إلى وضعه الطبيعي بدون تصفية. عند طباعة أي صنف آخر

 

Private Sub CommandButton1_Click()
    ' ... الأكواد الحالية ...

    ' عرض نافذة الطباعة
    Application.Dialogs(xlDialogPrint).Show

    ' إلغاء عملية التصفية بعد الطباعة
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    End If
End Sub

 

 

[mohamedyousef]

استاذي الفاضل شكرا على الاهتمام 

انا اريد عند اختيار صنف معين من داخل الكمبوبكس واضغط على طباعة الخامة المعينة يطبع المطلوب وفي نفس الوقت بعد الانتهاء يقوم بالغاء الفلترة من الملف دون الدخول عليه فعند البحث عن اي صنف لايظهر بيانات نظرا لان الملف من الداخل قد تم عمل فلتر عليه اثناء الطباعة وذلك على وانا ارسلت الملف لحضرتك للتوضيح فاذا قمت باختيار طباعة صنف معين يقوم الملف بعمل فلترة من الداخل اريد عند الانتهاء يلغي الفترة 

CommandButton2

900.xlsm

[ابا اسماعيل]

بهذا الشكل، عندما تقوم باختيار صنف من الكمبوبوكس وتضغط على زر الطباعة، سيتم تنفيذ عملية الطباعة للصنف المختار وسيتم إلغاء عملية التصفية

 

Private Sub CommandButton2_Click()
    With Worksheets("التكويد").Range("A1:T1")
        ' إلغاء الفلتر إذا كان مفعلاً
        If ActiveSheet.AutoFilterMode Then
            ActiveSheet.AutoFilterMode = False
        End If

        If Me.ComboBox1.Text = "" Then Exit Sub

        ' تنفيذ عملية التصفية
        .AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Text
    End With

    ' استدعاء الطباعة
    Call CommandButton1_Click

    ' إلغاء الفلتر بعد الطباعة
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    End If
End Sub

 

[mohamedyousef]

استاذي الفاضل 

اعتزر لحضرتك على تعبك معايا ولكن الوضع كما هو استاذي عند الضغط على طباعة صنف معين فعلا يقوم بطباعة المراد ولكن في صفحة التكويد داخل الملف يكون هناك فلتر بالاصناف المختارة داخل الكمبوبكس مما يعيق عند القيام مثلا بفورم رقم 1 الخاص بالاضافة او الصرف عند مثلا القيام باختيار الصنف رقم 5 لايوجد به بيانات وهذا لان صفحة التكويد اذا حضرتك قمت بفتحها تجد انه لايوجد كود رقم 5 بسبب الفلتر فلابد ان ادخل على الملف واقوم بالغاء الفلتر واعود مرة اخرى لفتح الفورم لكي يتم تعبئة اذن الاضافة 

اتمنى ان اكون وصلت المشكلة 

[ابا اسماعيل]

Private Sub CommandButton1_Click()
    ' إلغاء عملية التصفية إذا كانت مفعلة
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    End If

    ' عرض نافذة الطباعة
    Application.Dialogs(xlDialogPrint).Show
End Sub

 

تم تعديل أغسطس 7, 2023 بواسطه ابا اسماعيل

[mohamedyousef]

المقصود الغاء الفلتر من على صفحة التكويد 

[حسونة حسين]

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

استبدل الاكواد في فورم 8 بهذه الاكواد

Private Sub CommandButton1_Click()
    Dim LRow As Long
    Dim namsh As String
    Dim wk, wk2 As Worksheet
    Dim x As Integer
    Dim check As Boolean
    namsh = "temp"
    Set wk = ThisWorkbook.Worksheets("التكويد")

    For Each wk2 In ThisWorkbook.Worksheets
        If wk2.Name Like namsh Then check = True: Exit For
    Next
    If check = False Then

        With ThisWorkbook
            .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = namsh
        End With
    End If

    Set wk2 = ThisWorkbook.Worksheets(namsh)
    wk2.Range("A1:E9999") = ""
    LRow = wk.Range("A999").End(xlUp).Row

    wk.Range("A1:A" & LRow & ",E1:E" & LRow & ",R1:R" & LRow & ",S1:S" & LRow & ",T1:T" & LRow).Copy wk2.Range("A1")

    With wk2
        Rowz = Application.WorksheetFunction.Subtotal(2, .Range("A2:A" & Rows(Rows.Count).End(xlUp).Row))
        .Range("B" & Rowz + 2) = "الاجمالي"
        .Range("C" & Rowz + 2) = "=ROUND(SUM(C2:C" & Rowz + 1 & "),2)"
        .Range("D" & Rowz + 2) = "=ROUND(SUM(D2:D" & Rowz + 1 & "),2)"
        .Range("E" & Rowz + 2) = "=ROUND(SUM(E2:E" & Rowz + 1 & "),2)"
        .Columns("A:E").AutoFit

        With wk2.Range("B" & Rowz + 2 & ":E" & Rowz + 2)
            .AddIndent = True
            .Font.FontStyle = "Times New Roman"
            .Font.Size = 16
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Interior.Color = RGB(237, 237, 220)
            .Font.Bold = False
            .Font.Bold = True
        End With
        .PageSetup.PrintArea = "A1:E" & Rowz + 2    'LRow
        Application.Dialogs(xlDialogPrint).Show
    End With
    Application.DisplayAlerts = False
    If ThisWorkbook.Worksheets.Count = 1 Then MsgBox "There Is only One Sheet. The Deletion Can't Be Done!", vbCritical: Exit Sub
    If Evaluate("=ISREF('" & namsh & "'!A1)") Then
        Sheets(namsh).Delete
    End If
    Application.DisplayAlerts = True
    wk.Activate
End Sub

Private Sub CommandButton2_Click()
    With ThisWorkbook.Worksheets("التكويد")
        With .Range("A1:T1")
            If Me.ComboBox1.Text = "" Then Exit Sub
            .AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Text & "*"
        End With
        Call CommandButton1_Click
        If .AutoFilterMode Then
            .ShowAllData
        End If
    End With
End Sub

Private Sub CommandButton3_Click()
    Unload Me
End Sub

Private Sub UserForm_Activate()
    Dim wk As Worksheet
    Dim v, e
    If ActiveSheet.AutoFilterMode Then
        ActiveSheet.AutoFilterMode = False
    End If
    Set wk = ThisWorkbook.Worksheets("التكويد")
    LRow = wk.Range("A999").End(xlUp).Row
    v = wk.Range("C2:C" & LRow).Value
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For Each e In v
            If Not .exists(e) Then .Add e, Nothing
        Next
        If .Count Then Me.ComboBox1.list = Application.Transpose(.keys)
    End With
End Sub

 

[mohamedyousef]

استاذي الفاضل 

انا متشكر جدا على الاهتمام والمساعدة ولكن الكود في مجمله يفي بالمطلوب ولكن هناك مشكلة تظهر لي عند الطباعة تظهر هذه الرسالة وعند فتح ملف PDF يظهر كل الاصناف مع انه اذا قمت بفتح ملف الاكسل اجد ما طلبته فعلا وانا مرسل لحضرتك صورة بالمشكلة 

وشكرا 

[حسونة حسين]

جرب هذا التعديل

 

900.xlsm

[mohamedyousef]

السلام عليكم

اتاذي نفس المشكلة بالنسبة لطباعة المخزن كله لايوجد به مشكلة المشكلة في زر طباعة صنف معين عند الضغط عليه تظهر الرسالة انه يوجد خطأ كما اوضحت سابقا حضرتك لو قمت بالتجربة سوف تعرف ماذا اقصد المشكلة موجودة في كلمة show all data. 

مع الشكر

[حسونة حسين]

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

قمت بالتجربه والكود ليس به مشكله عندى ممكن احد الاعضاء يجرب الملف عنده ويوافينا بالنتيجه

[mohamedyousef]

السلام عليكم 

استاذي الفاضل قد قمت بتجربة الملف على اكثر من جهاز والمشكلة قائمة عند الطغط على امر طباعة صنف معين واختار حفظ pdf تظهر هذه الرسالة

[حسونة حسين]

عدل هذا السطر

If .AutoFilterMode Then
   .ShowAllData
End If

الى

If .AutoFilterMode Then
On Error Resume Next
    .ShowAllData
On Error GoTo 0
End If

والافضل من هذا

من الواضح ان الاوفيس الخاص بك ٢٠٠٧

قم بتغيير الاوفيس من ٢٠٠٧

الى اوفيس اعلى وليكن ٢٠١٠

مش عايز اقولك ٢٠٢١

لان الكود يعمل عندى بدون مشاكل على اوفيس٢٠١٠

[mohamedyousef]

السلام عليكم استاذي الفاضل

الف مليون شكر على المساعدة كده تمام ربنا يباركلك ولكن هو في مشكلة اساسية في الملف مسببالي ازعاج وهي في صفحة اذونات الصرف موجود كود يعطي رسالة لا يوجد رصيد كافي انا محتاج عند التسجيل فقط داخل اذن الصرف لو لا يوجد رصيد كافي يمنع المستخدم من التسجيل اما في طلب اذن الاضافة والمرتجع فبالطبع عادي بمعني الرسالة تظهر فقط عند التسجيل في اذن الصرف 

والف شكر مرة اخرى على المساعدة ربنا يكثر من امثالك 

السلام عليكم 

[حسونة حسين]

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

قم اخي بفتح موضوع جديد بهذا الطلب

[mohamedyousef]

كل مرة افتح موضوع جديد ادارة المنتدى ترسل لي حظر على الموضوع وانا لا اعلم كيف اقوم بفتح موضوع جديد لا يكون مخالف لقواعد المنتدى فممكن تساعدني كيف اقوم بذلك واكتب ايه في اسم الموضوع تجنبا لحدوث اخطاء

[حسونة حسين]

اداره المنتدي ترسل لك تحذير بان الموضوع مكرر 

اخي @mohamedyousef

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

او يجتهدوا لك في الاجابه عليه

فتستعجل الاجابه فتقوم بفتح موضوع جديد بنفس السؤال فترسل لك الاداره تحذير بان الموضوع مكرر

وهذه قواعد المشاركة فى الموقع

يمكنك الضغط هنـــــــــا لقراءة القواعد كاملة
و بصفة خاصة نؤكد على ما يلي
1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة
2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد.
3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال.
4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا.....
5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم.
ومخالفة ذلك تعرض الموضوع للحذف

[mohamedyousef]

الف شكر على مجهودات حضراتكم 

[mohamedyousef]

عزا اخي الفاضل

بالنسبة للموضوع السابق ذكره وهو انه عند طباعة صنف معين واقوم باختياره لابد وان اقوم يطبعه مرة اخرى لكي يتحقق المطلوب ففي اول مرة اقوم باختيار الصنف واقوم بطباعته يظهر لي ملف pdf بكل الاصناف وعندما اقوم بطبعه مرة اخرى يظهر المراد طبعه فكيف لي ان احل هذه المشكلة انا استخدم اوفيس 2007