T4588_Collate Sheets From XLSX Files Application StatusBar

https://excel-egy.com/forum/t4588
---------------------------------

Sub Collate_Sheets_From_XLSX_Files_Application_StatusBar()
    'اختيار المجلد الذي يحتوي على المصنفات المراد نسخ أوراق العمل منها
    Dim xFileDialog As FileDialog, xStrPath As String
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

    With xFileDialog
        .AllowMultiSelect = False
        .Title = "Select A Folder [Kutools For Excel - Excel-Egy]"
        If .Show = -1 Then xStrPath = xFileDialog.SelectedItems(1)
        If xStrPath = "" Then MsgBox "Operation Annulée", vbExclamation: Exit Sub
    End With

    'احتساب عدد المصنفات الموجودة في المجلد المحدد
    Dim fld As String, lst As Variant, num As Integer
    fld = Chr(34) & xStrPath & "\*.xlsx" & Chr(34)
    lst = Filter(Split(CreateObject("WScript.Shell").exec("cmd /c Dir " & fld & " /b /a-d").stdout.readall, vbCrLf), ".")
    num = UBound(lst) + 1

    'التعامل مع أول مصنف في المسار المحدد
    Dim xFile As String
    xFile = Dir(xStrPath & "\*.xlsx")

    'تحديد عدد المسافات في شريط الحالة
    Dim numberOfBars As Integer
    numberOfBars = 60
    Application.StatusBar = "[" & Space(numberOfBars) & "]"

    'بدء عملية النسخ وبدء الحلقة التكرارية
    Application.ScreenUpdating = False
        Do While xFile <> ""
            Dim wb As Workbook
            Set wb = Workbooks.Open(xStrPath & "\" & xFile)

            'استرجاع خاصية اهتزاز الشاشة لرؤية التقدم في شرط الحالة
            'وتوضع هذه الأسطر داخل الحلقة التكرارية لبيان التقدم
            Dim cnt As Integer, currentStatus As Integer, pctDone As Integer
            Application.ScreenUpdating = True
                Application.Wait Now + TimeValue("00:00:03")
                cnt = cnt + 1
                currentStatus = Int((cnt / num) * numberOfBars)
                pctDone = Round(currentStatus / numberOfBars * 100, 0)
                Application.StatusBar = "[" & String(currentStatus, "|") & Space(numberOfBars - currentStatus) & "]" & " " & pctDone & "% Complete"
            Application.ScreenUpdating = False

            'نسخ أوراق العمل من المصنف المفتوح للمصنف الحالي ثم إغلاقه في النهاية
            Dim ws As Worksheet
            For Each ws In wb.Sheets
                ws.Copy After:=ThisWorkbook.Sheets(1)
            Next ws
            wb.Close False

            xFile = Dir
        Loop

        'استرجاع شريط الحالة لما كان عليه قبل تنفيذ الكود
        Application.StatusBar = Empty
    Application.ScreenUpdating = True

    MsgBox "Done...", 64
End Sub