مساعده فى تحويل امتداد الملفات داخل درايف معين من الامتداد .xlsb الى .xlsx

[saad abed]

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

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

يمكنى من حذف ملفات اكسيل ذات امتداد معين ونقله الى فولدر فى السى 

واليوم

اطلب نفس الطريقة ولكن لتحويل الامتداد .xlsb الى .xlsx

كل الشكر للمشرفين والخبراء فى هذا المنتدى الحبيب

تم تعديل بالامس في 16:47 بواسطه saad abed

[محمد هشام.]

تفضل أخي بناء على نفس الفكرة السابقة أرفق لك ملف يحتوي على كودين:

 الكود الأول: إنشاء مجلدات وملفات بصيغة xlsb للتجربة تم تعديل الكود بحيث يمكنك:

1) اختيار البارتيشن الذي تريد إنشاء الملفات فيه 2)  تحديد عدد المجلدات التي سيتم إنشاؤها  3) تحديد عدد الملفات داخل كل مجلد حسب حاجتك

الكود الثاني: تحويل جميع ملفات xlsb في البارتيشن المحدد  الكود يقوم بـالبحث داخل البارتيشن الذي تحدده وتحويل جميع الملفات ذات الامتداد  xlsb إلى صيغة أخرى xlsx  داخل البارتشن المحدد حتى وإن كانت مخزنة داخل مجلدات فرعية متداخلة

Option Explicit
Sub Convertfiles()
    Dim dl As Object, n As String, ky As String
    Dim files() As String, i As Long, a As Long
    Dim startTime As Double, confirm As VbMsgBoxResult

    n = "F:\"  '   لا تنسى تعديل إسم البارتيشن بما يناسبك
    confirm = MsgBox("سيتم تحويل جميع الملفات بصيغة xlsb إلى xlsx" & vbCrLf & _
                     "هل تريد المتابعة؟", vbYesNo + vbQuestion, n & " " & "محرك الأقراص")
    If confirm <> vbYes Then Exit Sub

    Set dl = CreateObject("Scripting.FileSystemObject")
    startTime = Timer

    SupApp True

    ky = tMps(dl, n)
    If Trim(ky) = "" Then
        MsgBox "xlsb" & " " & "لم يتم العثور على أي ملفات بصيغة ", vbInformation
        GoTo Cleanup
    End If

    files = Split(ky, vbCrLf)
    a = 0

    For i = LBound(files) To UBound(files)
        If Trim(files(i)) <> "" Then
            If CntFiles(Trim(files(i)), dl) Then
                a = a + 1
            End If
        End If
    Next i

    MsgBox "تم تحويل" & a & " ملف بنجاح" & vbCrLf & _
           "استغرق التنفيذ " & Format(Timer - startTime, "0.00") & " ثانية", vbInformation

Cleanup:
    SupApp False
End Sub

Function CntFiles(filePath As String, dl As Object) As Boolean
    Dim wb As Workbook
    Dim newPath As String

    On Error GoTo ClearApp

    Set wb = Workbooks.Open(filePath, ReadOnly:=False)
    newPath = Replace(filePath, ".xlsb", ".xlsx")

    wb.SaveAs fileName:=newPath, FileFormat:=xlOpenXMLWorkbook
    wb.Close SaveChanges:=False

    If dl.FileExists(newPath) Then
        dl.DeleteFile filePath, True
        CntFiles = True
    End If

    Exit Function

ClearApp:
    CntFiles = False
    If Not wb Is Nothing Then wb.Close SaveChanges:=False
End Function

Function tMps(dl As Object, n As String) As String
    Dim root As Object, list As Collection, item As Variant, result As String
    On Error Resume Next
    Set root = dl.GetFolder(n)
    If root Is Nothing Then Exit Function
    On Error GoTo 0

    Set list = New Collection
    Call ScanFiles(dl, root, list)

    For Each item In list
        result = result & item & vbCrLf
    Next item

    tMps = result
End Function

Sub ScanFiles(dl As Object, folder As Object, ByRef list As Collection)
    Dim file As Object, subFolder As Object, fName As String

    fName = LCase(folder.Path)
    If InStr(fName, "$recycle.bin") > 0 Then Exit Sub
    If InStr(fName, "system volume information") > 0 Then Exit Sub

    For Each file In folder.files
        If LCase(dl.GetExtensionName(file.Name)) = "xlsb" Then
            list.Add file.Path
        End If
    Next

    For Each subFolder In folder.SubFolders
        ScanFiles dl, subFolder, list
    Next
End Sub

 

TEST4.xlsm

تم تعديل بالامس في 19:34 بواسطه محمد هشام.

[saad abed]

اخى محمد هشام

الكود يعمل بكفاءه عاليه جزاك الله خيرا اخى محمد

عامل السرعه فى كود تحويل الملفات هل الغاء الرسائل يعمل على زيادة سرعة الكود

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

[محمد هشام.]

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

عامل السرعه فى كود تحويل الملفات هل الغاء الرسائل يعمل على زيادة سرعة الكود

 1) أولا يسعدنا أخي @saad abed أننا إستطعنا مساعدتك 

2) نعم إلغاء الرسائل وتحديث الشاشة يسرع الكود بشكل كبير 

Sub SupApp(ByVal disable As Boolean)
    With Application
        If disable Then
            .ScreenUpdating = False
            .EnableEvents = False
            .DisplayAlerts = False
            .Calculation = xlCalculationManual
        Else
            .ScreenUpdating = True
            .EnableEvents = True
            .DisplayAlerts = True
            .Calculation = xlCalculationAutomatic
        End If
    End With
End Sub

وقد تم تطبيق ذلك في الكود باستخدام SupApp(True) لأنها  توقف التحديث البصري للشاشة وتمنع ظهور رسائل التنبيه مثل هل تريد حفظ التغييرات؟ وتوقف الأحداث البرمجية مثل الأكواد المرتبطة بفتح الملفات وكدالك تعطل إعادة الحساب التلقائي للصيغ هذا ما يحسن من سرعة الكود ويقلل من وقت تنفيذ العمليات بشكل ملحوظ خاصة عند معالجة عدد كبير من الملفات