تحويل ملفات بي دي اف الى فولدرات

[sabah19672025]

السلام عليكم - 

محتاج كود بالاكسل - يقوم بنقل ملف بي دي اف الى فولدر وفي داخل الفولدر الملف بي دي اف وكل فولدر يحمل الاسم الموجود في ملف بي دي اف

كما بالملفات المرفقة 

21 A 74044.pdf 21K11967 مرسيدس.pdf تحويل الى ملفات.xlsm

تم تعديل بالامس في 10:30 بواسطه sabah19672025

[محمد هشام.]

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

أخي @sabah19672025 أعتقد أن طلبك غير واضح نوعا ما 

 يمكن تنفيذ ذلك بعدة طرق حسب طريقة عملك واحتياجك ونحتاج فقط لتحديد الطريقة التي تفضل استخدامها:

  هل اختيار الملفات يدويا أي يتم عرض نافذة لتحديد ملفات PDF التي تريد نقلها (واحد أو أكثر) وسيقوم الكود تلقائيا بـإنشاء مجلد بنفس اسم كل ملف و نقل الملف إلى داخل هذا المجلد

أم البحث داخل مجلد معين بحيث يتم تحديد مجلد يحتوي على الملفات المعنية و البحث داخله تلقائيا عن كل ملفات PDF مع إنشاء مجلد بنفس اسم كل ملف و نقل كل ملف إلى المجلد المناسب دفعة واحدة

عموما إليك عدة إحتمالات يمكن إختيار ما يناسبك منها

Sub test_MovePDF()
    Dim dl As FileDialog, selectedItems As Variant, fso As Object, i As Integer
    Dim xPath As String, xName As String, xFolder As String, newFolder As String

    Set dl = Application.FileDialog(msoFileDialogFilePicker)
    With dl
        .AllowMultiSelect = True
        .Title = "اختر ملفات PDF"
        .Filters.Clear
        .Filters.Add "PDF Files", "*.pdf"
        
        If .Show <> -1 Then
            MsgBox "لم يتم اختيار أي ملفات", vbExclamation
            Exit Sub
        End If
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        For i = 1 To .selectedItems.Count
            xPath = .selectedItems(i)
            xName = fso.GetFileName(xPath)
            xFolder = fso.GetParentFolderName(xPath)
            newFolder = xFolder & "\" & Left(xName, Len(xName) - 4)
            
            If Not fso.FolderExists(newFolder) Then
                fso.CreateFolder newFolder
            End If
            
            Name xPath As newFolder & "\" & xName
        Next i
    End With

    MsgBox "تم نقل الملفات بنجاح", vbInformation
End Sub

'===================================
Sub Move_Selected_PDFs_To_Folders()
    Dim fso As Object, fd As FileDialog
    Dim i As Long
    Dim xPath As String, fileName As String, xFolder As String, newFolder As String
    Dim baseName As String

    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "اختر ملفات PDF المتفرقة"
        .Filters.Clear
        .Filters.Add "PDF Files", "*.pdf"
        .AllowMultiSelect = True

        If .Show <> -1 Then
            MsgBox "لم يتم اختيار أي ملفات", vbExclamation
            Exit Sub
        End If

        Set fso = CreateObject("Scripting.FileSystemObject")
        
        For i = 1 To .selectedItems.Count
            xPath = .selectedItems(i)
            fileName = fso.GetFileName(xPath)
            xFolder = fso.GetParentFolderName(xPath)
            baseName = fso.GetBaseName(fileName)

            newFolder = xFolder & Application.PathSeparator & baseName
            
            If Not fso.FolderExists(newFolder) Then
                fso.CreateFolder newFolder
            End If
           Name xPath As newFolder & Application.PathSeparator & fileName
        Next i
    End With

    MsgBox "تم نقل الملفات بنجاح", vbInformation
End Sub

'=========================================
Sub test_Move_allPDF()
    Dim fso As Object, file As Object, newFolder As String
    Dim xFolder As String, xName As String, xPath As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "اختر المجلد الذي يحتوي على ملفات PDF"
        If .Show <> -1 Then Exit Sub
        xFolder = .selectedItems(1)
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each file In fso.GetFolder(xFolder).Files
        If LCase(fso.GetExtensionName(file.Name)) = "pdf" Then
            xName = fso.Getn(file.Name)
            xPath = file.Path
            newFolder = xFolder & Application.PathSeparator & xName
            If Not fso.FolderExists(newFolder) Then
                fso.CreateFolder newFolder
            End If
            Name xPath As newFolder & Application.PathSeparator & file.Name
        End If
    Next file

    MsgBox "تم نقل الملفات بنجاح", vbInformation
End Sub

 

تحويل الى ملفات v2.xlsm

تم تعديل منذ 2 ساعات بواسطه محمد هشام.