logo

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ملك محمد لا تميز خلال هذه الفترة-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة قسم البرامج العامة



أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





  • غير مجابة
15-05-2022 04:01 مساءً
السلام عليكم ورحمه الله وبركاته
ممكن المساعده فى عمل كود لنسخ ملفات PDF و اكسيل من مجلد إلى مجلد آخر بالاعتماد على قائمة فى ملف اكسيل ( العمود A ) مع مراعاه أن وجد ملفات متشابها يتم نسخ المتشابه أيضاً




look/images/icons/i1.gif نسخ ملفات pdf و Excel من مجلد إلى مجلد بالاعتماد على قائمة فى ملف اكسيل
  02-04-2023 05:54 صباحاً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 15-02-2018
رقم العضوية : 4397
المشاركات : 449
رصيد العضو : 0
الجنس :
تاريخ الميلاد : 29-12-1985
قوة السمعة : 1085
الاعجاب : 0
وعليكم السلام
على حسب ما فهمت من حضرتك
CODE
Sub CopyFilesBasedOnList()
    
    'تحديد المجلد الذي يحتوي على الملفات المراد نسخها
    Dim sourceFolder As String
    sourceFolder = "C:FolderName"
    
    'تحديد المجلد الذي يحتوي على الملفات المراد لصقها
    Dim destFolder As String
    destFolder = "C:NewFolderName"
    
    'تحديد اسم ملف الاكسل ورقم الورقة المستخدمة
    Dim wb As Workbook
    Dim ws As Worksheet
    Set wb = Workbooks("ExcelFileName.xlsx")
    Set ws = wb.Worksheets("Sheet1")
    
    'تحديد المدى الذي يحتوي على الأسماء في العمود A
    Dim lastRow As Long
    lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Dim nameRange As Range
    Set nameRange = ws.Range("A2:A" & lastRow)
    
    'تحديد كل الملفات في المجلد المحدد
    Dim file As Variant
    Dim files As Collection
    Set files = New Collection
    Dim fileName As String
    fileName = Dir(sourceFolder & "*")
    While fileName <> ""
        files.Add fileName
        fileName = Dir()
    Wend
    
    'تنفيذ النسخ
    Dim cell As Range
    Dim fileExists As Boolean
    For Each cell In nameRange
        fileExists = False
        For Each file In files
            If InStr(1, file, cell.Value, vbTextCompare) > 0 Then
                If fileExists = False Then
                    'نسخ الملف إلى المجلد المحدد
                    FileCopy sourceFolder & file, destFolder & file
                    fileExists = True
                Else
                    'إذا وجد ملفات متشابهة، يتم نسخها أيضا
                    FileCopy sourceFolder & file, destFolder & "(1)" & file
                End If
            End If
        Next file
    Next cell
    
    MsgBox "تمت العملية بنجاح"
    
End Sub

-------------------------
ملحوظه: يقوم الكود بنسخ جميع الملفات الموجودة في المجلد المحدد (sourceFolder) والتي تم تحديدها في قائمة في ملف Excel في العمود A إلى المجلد الجديد (destFolder). كما يتم مراعاة نسخ الملفات المتشابهة. 
يجب عليك تغيير قيم المتغيرات (sourceFolder و destFolder و ExcelFileName و Sheet1) لتتناسب مع احتياجاتك.




اضافة رد جديد اضافة موضوع جديد



المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
برنامج حماية وفك حماية ملفات الاكسيل والاكسيس والملفات التنفيذية وحماية unviewable Yasser Elaraby
12 1649 Yasser Elaraby
تجميع بيانات من عدة ملفات بليغ البتول
2 320 صلاح الصغير
07 _ دمج المراسلات باستخدام البايثون (إنشاء العديد من ملفات الورد) YasserKhalil
8 885 karwan
المساعد فى تعديل كود نسخ البيانات من ملفات مغلقة Lotfy
0 94 Lotfy
كود نسخ البيانات من ملفات اكسيل مغلقة Lotfy
0 309 Lotfy

الكلمات الدلالية
ملفات ، Excel ، مجلد ، مجلد ، بالاعتماد ، قائمة ، اكسيل ،









اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 01:45 PM