هل هناك طريقة لحفظ ملف مفلتر لوحده

[alaa_1982]

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

الرجاء المساعدة

لدي ملف يحتوي عدة شيتات

وإحدى هذه الشتات فيها جدول مفلتر حسب قيم معينة 

الذي اريده هو حفظ هذا الجدول الفلتر لوحده فقط في ملف خارجي و باسم مختلف 

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

؟

[الـعيدروس]

السلام عليكم

استخدم هذا الكود

Private Sub Copy_Filtr(wb As Workbook, ws As Worksheet, Rng As Range, Optional sFile As String)
Dim Pth
Dim N_Book As Workbook
Pth = ActiveWorkbook.Path & Application.PathSeparator
If IsFile(Pth & sFile & ".xlsx") Then
    MsgBox "الملف موجود مسبقاً بنفس الاسم" & vbCrLf & "اعد المحاولة بأسم اخر"
    Exit Sub
End If
Set N_Book = Workbooks.Add
wb.Sheets(ws.Name).Range(Rng.Address).Copy
With N_Book
    With .Sheets(1)
        .Range("a1").PasteSpecial (xlPasteAll)
        .UsedRange.Columns.AutoFit
    End With
    .SaveAs FileName:=Pth & sFile & ".xlsx"
    .Close
End With
End Sub
Private Function IsFile(ByVal fName As String) As Boolean
    If Dir(fName, vbDirectory) <> vbNullString Then
        IsFile = True
    Else
        IsFile = False
    End If
End Function
Sub My_Fl()
Application.DisplayAlerts = False
With ActiveWorkbook.ActiveSheet
    Dim lRow, Cl, On_R
    Cl = Split(.UsedRange.Address, "$")(3)
    On_R = Split(.UsedRange.Address, "$")(1) & "1:": lRow = Split(.UsedRange.Address, "$")(4)
    With .Range(On_R & Cl & lRow)
        Copy_Filtr ActiveWorkbook, ActiveSheet, .SpecialCells(xlCellTypeVisible), "My_Filtr3"
    End With
End With
End Sub

 

تم تعديل نوفمبر 8, 2019 بواسطه الـعيدروس

[الـعيدروس]

او هكذا

يستبدل الملف ماتم سابقاً 

 

Private Sub Copy_Filtr(wb As Workbook, ws As Worksheet, Rng As Range, Optional sFile As String)
Dim Pth, My_Pth
Dim N_Book As Workbook
Pth = ActiveWorkbook.Path & Application.PathSeparator
My_Pth = Pth & sFile
Set N_Book = Workbooks.Add
wb.Sheets(ws.Name).Range(Rng.Address).Copy
With N_Book
    With .Sheets(1)
        .Range("a1").PasteSpecial (xlPasteAll)
        .UsedRange.Columns.AutoFit
    End With
    Application.DisplayAlerts = False
     .SaveAs FileName:=My_Pth & ".xlsx"
     .Close
    Application.DisplayAlerts = True
End With
End Sub
Sub My_Fl()
With ActiveWorkbook.ActiveSheet
    Dim lRow, Cl, On_R
    Cl = Split(.UsedRange.Address, "$")(3)
    On_R = Split(.UsedRange.Address, "$")(1) & "1:": lRow = Split(.UsedRange.Address, "$")(4)
    With .Range(On_R & Cl & lRow)
        Copy_Filtr ActiveWorkbook, ActiveSheet, .SpecialCells(xlCellTypeVisible), "My_Filtr3"
    End With
End With
End Sub