كود لالغاء ملفات الاكسيل بامتداد معين.xlsb

[saad abed]

السلام عليكم

هل هناك كود يمكنى من الالغاء ملفات اكسيل بامتداد معين مثلا .xlsb فى درايف معين او فى كل الدريفات

[محمد هشام.]

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

هل تقصد حدف الملفات 

ادا كان كدالك  فالكود قد يستغرق وقتا طويلا  وقد يجمد Excel أحيانا خاصة عند البحث داخل درايف كامل (مثلD)  يحتوي على آلاف الملفات والمجلدات 

 الأفضل تحديد مجلد معين داخل بارتيشن  معين سيكون افضل واسرع

 

[saad abed]

السلام عليكم اخى محمد

نعم اريد حذف ملفات الاكسيل ذات الامتداد .xlsb من دريف معين

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

 

[عبدالله بشير عبدالله]

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

جرب الكود التالي 

اذا ظهر خطا بالكود ربما تحتاج تشغيل  تطبيق اكسل كمسؤول

 

Sub DeleteXLSBFromDriveD()
    Dim folderPath As String
    folderPath = "D:\"
    
    Call DeleteXLSBRecursive(folderPath)
    
    MsgBox "تم حذف جميع ملفات .xlsb من الدرايف D (حذف).", vbInformation
End Sub

Sub DeleteXLSBRecursive(folderPath As String)
    Dim fs As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim file As Object
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    On Error Resume Next
    Set folder = fs.GetFolder(folderPath)
    If folder Is Nothing Then
        Debug.Print "Cannot access folder: " & folderPath
        Exit Sub
    End If
    On Error GoTo 0

    On Error Resume Next
    Dim fileCount As Long
    fileCount = folder.Files.Count
    If Err.Number <> 0 Then
        Debug.Print "Error accessing files in: " & folderPath & " - " & Err.Description
        Err.Clear
        On Error GoTo 0
        Exit Sub
    End If
    On Error GoTo 0

    If fileCount > 0 Then
        For Each file In folder.Files
            On Error Resume Next
            If LCase(fs.GetExtensionName(file.Name)) = "xlsb" Then
                SetAttr file.Path, vbNormal
                Kill file.Path
                If Err.Number <> 0 Then
                    Debug.Print "Failed to delete: " & file.Path & " - Error: " & Err.Description
                    Err.Clear
                End If
            End If
            On Error GoTo 0
        Next file
    End If
    
    For Each subFolder In folder.SubFolders
        DeleteXLSBRecursive subFolder.Path
    Next subFolder
End Sub

 

تم تعديل منذ 13 ساعات بواسطه عبدالله بشير عبدالله

[محمد هشام.]

 

3 ساعات مضت, saad abed said:

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

ادن لنجرب طريقة أخرى 

 

Option Explicit
Sub Testxlsb()
    Dim xPath As String, n As Double
    Dim startTime As Double, xList As String
    Dim sCount As Long, confirm As VbMsgBoxResult
    xPath = "D:\"
    xList = ""
    With Application
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual
    startTime = Timer

    tmps xPath, xList
    
    If xList = "" Then
        MsgBox "لم يتم العثور على أي ملفات بامتداد xlsb في " & xPath
    Else
    
        sCount = UBound(Split(Trim(xList), vbCrLf))
        
        confirm = MsgBox("تم العثور على " & sCount & " ملف بامتداد xlsb " & vbCrLf & _
                         "هل تريد حدفها ونقلها إلى  مجلد الملفات المحدوفة ؟", vbYesNo + vbQuestion)
        If confirm = vbYes Then
            tbl xPath, xList
            Snames xList
            MsgBox "تم الحذف وحفظ أسماء الملفات في  C:\الملفات المحدوفة\filName.txt"
        Else
            MsgBox "تم إلغاء العملية لم يتم حذف أي ملفات"
        End If
    End If
    
    .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
    End With
    n = Timer - startTime
    MsgBox "تم تنفيذ العملية في: " & Format(n, "0.00") & " ثانية"
End Sub

Sub tmps(ByVal xPath As String, ByRef xList As String)
    Dim fso As Object, Folder As Object, file As Object, sFiles As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    On Error Resume Next
    Set Folder = fso.GetFolder(xPath)
    If Folder Is Nothing Then Exit Sub
    On Error GoTo 0

    If Not Folder Is Nothing Then
        On Error Resume Next
        For Each file In Folder.Files
            If (file.Attributes And 2) = 0 And (file.Attributes And 4) = 0 Then
                If LCase(fso.GetExtensionName(file.Name)) = "xlsb" Then
                    xList = xList & file.Path & vbCrLf
                End If
            End If
        Next
        On Error GoTo 0

        On Error Resume Next
        For Each sFiles In Folder.sFiless
            tmps sFiles.Path, xList
        Next
        On Error GoTo 0
    End If
End Sub

Sub tbl(ByVal xPath As String, ByRef xList As String)
    Dim fso As Object, Folder As Object, file As Object, sFiles As Object
    Dim CntFile As String, r As String, ky As Integer
    CntFile = "C:\الملفات المحدوفة\DeletedXLSB\"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists("C:\الملفات المحدوفة\") Then fso.CreateFolder ("C:\الملفات المحدوفة\")
    If Not fso.FolderExists(CntFile) Then fso.CreateFolder (CntFile)
    
    On Error Resume Next
    Set Folder = fso.GetFolder(xPath)
    If Folder Is Nothing Then Exit Sub
    On Error GoTo 0

   On Error Resume Next
For Each file In Folder.Files
    If Err.Number = 0 Then
        If (file.Attributes And 2) = 0 And (file.Attributes And 4) = 0 Then
            If LCase(fso.GetExtensionName(file.Name)) = "xlsb" Then
             
                r = CntFile & fso.GetFileName(file.Path)
                ky = 1
                While fso.FileExists(r)
                    r = CntFile & "Copy_" & ky & "_" & fso.GetFileName(file.Path)
                    ky = ky + 1
                Wend

                file.Move r
            End If
        End If
    End If
    Err.Clear
Next
    For Each sFiles In Folder.sFiless
        tbl sFiles.Path, xList
    Next
    On Error GoTo 0

End Sub

Sub Snames(xList As String)
    Dim fileNum As Integer
    fileNum = FreeFile
    On Error Resume Next
    Open "C:\الملفات المحدوفة\filName.txt" For Output As #fileNum
    Print #fileNum, xList
    Close #fileNum
    On Error GoTo 0
End Sub

 

TEST2.xlsm

[saad abed]

اخى عبدالله بشير عبدالله

اخى محمد هشام

كل الشكر والتقدير لكم اخوتى الاكارم

جارى التجربه ولكن مجهودكم كبير تشكرون عليه

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

 

 

 

تم تعديل منذ 20 دقائق بواسطه saad abed