كود نقل ملفات لمجلدات معينة

[Ali Ammar]

لدي كود برمجي  اطلب منه نسخ ملفات pdf الى مجلد يحتوي على 100 مجلد وكل مجلد من ال 100 يوجد فيه 10 مجلدات  الكود التالي يقوم بنسخ  الملفات الي جانب ال 10 مجلدات  هل يمكن المساعدة في تعديل الكود ليقوم بالمطلوب وهو اريد نسخ الملف الى مجلد اقم باختياره  عبرة نافذة  يقدمها البرنامج  من ال 10 مجلدات فرعية  التي تحتوي عليها المجلدات ال 100

Sub CopyMatchingFilesAndFolders()
    Dim sourcePath As String
    Dim targetPath As String
    Dim sourceFiles As Collection
    Dim targetFolders As Collection
    Dim fileName As String
    Dim folderName As String
    Dim fileItem As Variant
    Dim folderItem As Variant
    Dim extension As String
    
    ' ?????? ???? ??????
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "اختيار مجلد المصدر"
        If .Show = -1 Then
            sourcePath = .SelectedItems(1) & "\"
        Else
            MsgBox "لم يتم اختيار مجلد المصدر ."
            Exit Sub
        End If
    End With
    
    ' ?????? ???? ?????
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "اختيار مجلد الهدف"
        If .Show = -1 Then
            targetPath = .SelectedItems(1) & "\"
        Else
            MsgBox "لم يتم اختيار مجلد الهدف "
            Exit Sub
        End If
    End With
    
    Set sourceFiles = GetFilesCollection(sourcePath)
    Set targetFolders = GetFoldersCollection(targetPath)
    
    For Each fileItem In sourceFiles
        fileName = fileItem
        extension = Right(fileName, 4) ' ?????? ???????? ".pdf"
        fileName = Left(fileName, Len(fileName) - Len(extension))
        
        For Each folderItem In targetFolders
            folderName = folderItem
            If Right(folderName, Len(extension)) = extension Then
                folderName = Left(folderName, Len(folderName) - Len(extension))
            End If
            
            If fileName = folderName Then
                FileCopy sourcePath & fileItem, targetPath & folderItem & "\" & fileItem
            End If
        Next folderItem
    Next fileItem
    
    MsgBox "تم نسخ الملفات بنجاح!"
End Sub

Function GetFilesCollection(ByVal path As String) As Collection
    Dim files As New Collection
    Dim file As String
    
    file = Dir(path & "*.*")
    Do While file <> ""
        If (GetAttr(path & file) And vbDirectory) = 0 Then
            files.Add file
        End If
        file = Dir
    Loop
    
    Set GetFilesCollection = files
End Function

Function GetFoldersCollection(ByVal path As String) As Collection
    Dim folders As New Collection
    Dim folder As String
    
    folder = Dir(path, vbDirectory)
    Do While folder <> ""
        If folder <> "." And folder <> ".." And (GetAttr(path & folder) And vbDirectory) <> 0 Then
            If InStr(1, folder, "-") > 0 Then
                folders.Add folder
            End If
        End If
        folder = Dir
    Loop
    
    Set GetFoldersCollection = folders
End Function

 

[أ / محمد صالح]

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

فمثلا ملف اسمه 17.pdf يتم نسخه في مجلد 17pdf

على أي أساس تريد وضعه في أحد المجلدات العشرة؟ داخل المجلد 17pdf ؟؟؟

[Ali Ammar]

على اساس ان يتطابق  اسم الملف مع اسم الملجد يقوم يفتح المجلد المتطابق بالاسم معه   ويطلب مني اختار الملجد الهدف الاخير  لمرة واحد فقط   لان  عدد الملفات كبيرة جدا ممكن 100 او حتى يمكن يوصل لل 1000

[أ / محمد صالح]

ربما الكلام غير منطقي أو متناقض

كيف يتم فتح مستعرض المجلدات لحضرتك أكثر من 1000 مرة لتختار مكان الملف في العشرة مجلدات 

؟؟؟؟؟؟؟؟

وما فائدة الكود إذن؟؟؟

مجرد أن يذهب بك إلى المجلد الذي باسم الملف لتختار منه موضع النسخ يديويا؟؟؟؟؟

[Ali Ammar]

استاذي الكريم  الكود سيقوم بالعملية ل 1000 ملف  يطلب  تحديد المجلد لمرة واحدة فقط  

فرضا لدي 1000 ملف  ومجلد A يحتوي على 1000 مجلد    مثال عن اسماء المجدلات ال1000  A1 ,A2,A3,A4,A5   .... الى A1000   بداخل كل مجلد  10 مجلدات فرعية  اسمائها/ A1-1/A1-2/A1-3....الخ

 يقوم الكود بمطابقة اسم الملف مع اسم المجلد (من مجلدA)  في حال التطابق يقوم بفتح المجلد  يظهر  قائمة مستعرض فيها اسماء المجلدات ال10 بمجرد اخيارك لمجلد واحد   يقوم الكود بتنفيذ النسخ لكل ملف يتطابق اسمه مع اسم المجلد من الالف  طبعا النسخ داخل مجلد 

اسماء المجلدات ال10 (/ A1-1/A1-2/A1-3....الخ) واحدة في ال 1000مجلد

مثلا: اسم الملف  A1   يذهب للمجلد  A1  هنا طابق اسم الملف لاسم المجلد  يقوم بفتح المجلد  هنا تظهر قائمة  فيها اسماء المجلدات ال10  هنا  نختار المجلد الهدف  ويقوم بنسخ  الملف بداخليه  ويتم تعميم العملية على جميع الملفات المتطابقة بالاسماء مع اسماء المجلدات  الرئيسة A1 ,A2,A3,A4,A5   .... الى A1000 

[أ / محمد صالح]

إذا كان مقصودك اختيار المجلد الفرعي من العشرة لمرة واحدة فلماذا لا يتم تمرير اسم المجلد الفرعي للكود ؟؟

مثلا المجلد الفرعي رقم 1 يتم نسخ جميع الملفات في المجلد الفرعي رقم 1 داخل المجلد الذي يوافق اسم الملف.

وفي هذه الحالة ما فائدة المجلدات الفرعية التسعة الأخرى؟؟؟!!!

على العموم

ضع متغيرا جديدا للمجلد الفرعي في آخر الإعلان عن المتغيرات

Dim extension As String
Dim subfolder as String

واستبدل هذه السطور قبل النسخ

If fileName = folderName Then
	FileCopy sourcePath & fileItem, targetPath & folderItem & "\" & fileItem
End If

إلى هذه والتي تعرض مستعرض المجلدات لمرة واحدة في أول ملف ابتداء من أول مجلد ثم يتم النسخ في المجلد الفرعي بنفس الاسم في جميع المجلدات المطابقة لاسماء الملفات

If fileName = folderName Then
If subfolder = "" then	
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "اختيار المجلد الفرعي"
		.InitialFileName = targetPath & folderItem & "\"
        If .Show = -1 Then
            subfolder = .SelectedItems(1) & "\"
        Else
            MsgBox "لم يتم اختيار المجلد الفرعي"
            Exit Sub
        End If
    End With
End If
	FileCopy sourcePath & fileItem, subfolder & fileItem
End If

بالتوفيق

[Ali Ammar]

ردا على سؤالك لما لا يتم تمرير اسم الملف  او اسم المجلد   اريد في كل مرة نقل ملفات  الي مجلدات مختلفة     شكرا الك رح اجرب الكود واردلك النتيجة  الف شكر الك