اضافة الفلتر مع الورقة

[Mharee Accounting Albaig]

السلام عليكم 

رمضان كريم وكل عام والجميع بالف خير 

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

ايضا تحتوي ورقة الناسخة على ( فلاتر في رؤوس الأعمدة ) وعندما اضيف ورقة بطلب اضافة حساب يتم اضافة كل كل شيء وتفتح صفحة جديدة ولكن بدون فلاتر ( اي لا توجد الفلاتر على رؤوس الأعمدة ) ارغب باضافتها مع الصفحة تلقائيا تضهر روؤس الأعمدة ومعها الفلاتر براس كل عامود محدد 

مع الشكر والتقدير 

 

ورقة بالفلتر.rar

[محمد هشام.]

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

أخي @Mharee Accounting Albaig  يفضل دائما إلغاء باسوورد محرر الأكواد  قبل رفع الملف لتفادي إهدار الوقت في كسره 

 

جرب هدا 

Private Sub CommandButton1_Click()
    On Error GoTo ErrorHandler
    Dim xlSheet As Worksheet, xlSh As Worksheet, crWS As Worksheet
    Dim Sht As Worksheet, B As VbMsgBoxResult, T As Long, i As Long, LastCol As Long
    
    Set Sht = ThisWorkbook.Sheets("كشف")
    Set crWS = ThisWorkbook.Sheets("الناسخة ")
    
    If Me.BackColor = 192 Or TextBox1.Text = "" Then
        MsgBox IIf(Me.BackColor = 192, "الاسم مرفوض نصياً", "خلايا فارغة"), vbInformation + vbMsgBoxRight, "تنبيه"
        Exit Sub
    End If
    
    For Each xlSh In ThisWorkbook.Worksheets
        If xlSh.Name = Trim(TextBox1.Text) Then MsgBox "اسم مكرر", vbInformation + vbMsgBoxRight, "تنبيه": Exit Sub
    Next xlSh
    
    B = MsgBox("هل تريد اضافة" & vbNewLine & vbNewLine & "الحساب:  " & _
        TextBox1.Text, vbOKCancel + vbQuestion + vbMsgBoxRight, "تأكيد اضافة حساب")
        If B = vbCancel Then Exit Sub
    
    Application.ScreenUpdating = False
    Set xlSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    With xlSheet
        .Name = TextBox1.Text
         crWS.Range("A1:R74").Copy
        .Cells.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        .Cells.PasteSpecial Paste:=xlPasteColumnWidths
         ActiveSheet.DisplayRightToLeft = True
          
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        If LastCol > 18 Then LastCol = 18
        .Range(.Cells(1, 1), .Cells(1, LastCol)).AutoFilter
        
        .PageSetup.LeftHeader = "كشف حساب " & TextBox1.Text
        .PageSetup.RightHeader = "اسم الشركة: Bina Puri sdn Bhd"
        With ActiveWindow
            .FreezePanes = True
            .DisplayGridlines = False
        End With
        xlSheet.Range("A1").Select
    End With
    
    T = Sht.Range("B" & Sht.Rows.Count).End(xlUp).Row + 1
    For i = 1 To ThisWorkbook.Sheets.Count
        If ThisWorkbook.Sheets(i).Name <> Sht.Name And ThisWorkbook.Sheets(i).Name <> crWS.Name Then
            Sht.Range("B" & T) = ThisWorkbook.Sheets(i).Name
            T = T + 1
        End If
    Next i
    
Cleanup:
    Application.ScreenUpdating = True
    Set xlSheet = Nothing
    Set Sht = Nothing
    Exit Sub

ErrorHandler:
    Resume Cleanup
End Sub

 

ورقة بالفلتر.xlsm

[Mharee Accounting Albaig]

الأخ العزيز الغالي

مشكور وجزاك الله خيرا على هذا الأبداع 

ربي يحفظك ويبارك بيك 

اعتذر عن عدم رفع الباسوورد بسبب النسيان 

تحياتي 

 

تم تعديل السبت at 13:06 بواسطه Mharee Accounting Albaig