نسخ مجموعة ملفات مرة واحدة باسم ملف متسلسل ( معدل )

[ايهاب سعيد]

هل يوجد كود يمكن عند فتح الملف ان ينسخ ملف معين مكان اي ملف اكسل موجود معه في نفس الفلودر

 

[أبو ردينة]

أرفق مثال اخي الكريم أ / ايهاب سعيد 
و بإذن الله تجد الحل المناسب

[طارق محمود]

السلام عليكم

أخي الكريم

إشرح قليلا لكي تساعد من أراد أن يشارك

 

نفرض أن بالمجلد ملفين ، "الأول" ، "الثاني" بالإضافة لملف ثالث مثلا إسمه "الكود"

 

هل المطلوب إذا فتحت ملف الكود ، يتم نسخ الأول بدلا من الثاني

أي سيحذف الثاني وينسخ نسخة من الأول بنفس إسم الثاني

[ايهاب سعيد]

السلام عليكم بالضبط اخي محمود فعند فتح ملف الكود مثلا يقوم بنسخ محتوياته باسم اي ملف موجود معه في المجلد ليصبح جميع الملفات تحتوي علي نفس البيانات الموجود بملف الكود

[طارق محمود]

السلام عليكم

 

أخي العزيز

لابد من التحديد أكثر

هل نتعامل أن جميع الملفات بما فيها ملف الكود بها نفس عدد الشيتات مثلا

[ايهاب سعيد]

اذا اردت نسخ ملف مكان ملف اخر فلا يهم عدد الشيتات

[ايهاب سعيد]

اخي العزيز ان الكود المطلوب تطويره هو

Sub Copy_File()
    FileCopy "e:\Test.xls", "f:\Test.xls"
End Sub
ولكني اريد ان انسخ مجموعة ملفات مرة واحدة باسم ملف متسلسل بمعني اريد نسخ ملفات موجودة بفولدر معين الي 1 -2 -3 وهكذا علي ان تشمل المحتويات بيانات الملف الرئيس tast

[ايهاب سعيد]

استاذ طارق وجدت لسيادتك كود يتعامل مع 100 شيت المطلوب نفس الكود ولكن يتعامل مع الملفات اي يقوم بنسخ الملف الرئيسي علي باقي الملفات ويلغي محتويات تلك الملفات

[طارق محمود]

السلام عليكم

أخي العزيز

أنت أوحيت لي بالحل في مشاركتك السابقة

تفضل الملف وبه الكود والشرح

سيعمل الكود علي الملفات التي امتدادها .xls فقط

وطبعا يمكن تعديله ليشمل كافة امتدادات الإكسل

الكود هو

Sub Copy_to_all()
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False


  pt = ActiveWorkbook.Path & "\"
  nm = ActiveWorkbook.Name
  ActiveWorkbook.SaveAs Filename:=pt & "tempo.xls"
  Name pt & nm As pt & "tempo2.xls"
  ActiveWorkbook.SaveAs Filename:=pt & nm


   file = Dir(pt)
   If file = nm Then file = Dir
    While (file <> "")
        If Right(file, 4) = ".xls" Then
            If file = "tempo.xls" Then file = Dir
                new_n = Left(file, Len(file) - 4)
            Kill pt & file
            FileCopy pt & "tempo.xls", pt & new_n & ".xls"
       End If
        file = Dir
    Wend
    
            Kill pt & "tempo.xls"
            Kill pt & "tempo2.xls"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

Copy to all.rar

[ايهاب سعيد]

سلمت يداك هو المطلوب بالضبط

[ايهاب سعيد]

الكود رائع اخي محمود وهو المطلوب ولكن لي طلب اضافي هلي يمكنان يقوم هذا الملف بنفس العمل ولكن لاي ملف مفتوح فقط اي عند الضغط علي الزر يقوم بنسخ بياناته للملفات المفتوحة فقط وتلقائي شكر لسياتك وارجو المعذرة لكثرة الطلبات

[طارق محمود]

السلام عليكم

أخي الكريم

لنسخ بياناته للملفات المفتوحة فقط (ليس شرطا ان تكون في نفس مساره) غير الكود إلي

Sub Copy_to_all()
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim f_name(99) As String

  pt = ActiveWorkbook.Path & "\"
  nm = ActiveWorkbook.Name
  ActiveWorkbook.SaveAs Filename:=pt & "tempo.xls"
    Kill pt & nm
  ActiveWorkbook.SaveAs Filename:=pt & nm

    d = 0
10    ActiveWindow.ActivateNext
    If ActiveWorkbook.Name = nm Then GoTo 20
        d = d + 1
        f_name(d) = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
        ActiveWindow.Close
    
GoTo 10
20 If d = 0 Then MsgBox ("No files open except this ..No change"): Exit Sub
       
       For i = 1 To d
            Kill f_name(i)
            FileCopy pt & "tempo.xls", f_name(i)
            Workbooks.Open Filename:=f_name(i)
       Next i
    
    Kill pt & "tempo.xls"

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

[ايهاب سعيد]

اخي محمود سلمت يداك ولكني عندما جربت الملف علي اوفيس 2007 لم يعمل بشكل جيد

ولكني سعيد جدا بما تم تنفيذه 

[طارق محمود]

السلام عليكم

أخي الكريم

وجدت في إحدي طلباتك أنك تعمل فقط علي الإمتداد xls

لذلك فقد حددته كذلك

وكما قلت لك بالمشاركة #7

سيعمل الكود علي الملفات التي امتدادها .xls فقط

وطبعا يمكن تعديله ليشمل كافة امتدادات الإكسل

 

 

[ايهاب سعيد]

مشكور اخي طارق

[ايهاب سعيد]

اخي طارق لاحظت ان الكود يعمل بشكل ممتاز ولكن في حالة اذا كان المجلد باللغة العربية لا يعمل فما السبب

[طارق محمود]

أعتقد السبب في إعدادات الأوفيس أو الويندوز

[على حسن]

مهندس طارق محمود انت كنز لهذا المنتدى

بارك الله فيك وجعله الله في ميزان حسناتك

[طارق محمود]

أخي الكريم / علي حسن
بارك الله فيك وفيمن تحب
ورزقكم الخير كله

[ايهاب سعيد]

اخي محمود لاحظت ان الكود يعمل ساعات ولا يعمل مرات اخري فما السبب

[طارق محمود]

لاحظت ان الكود يعمل ساعات ولا يعمل مرات اخري فما السبب

 

 

لا أدري

ولكن يمكنك إيقاف تفعيل اول أمر في الكود بعمل ' أبوستوف قبله هكذا

On Error Resume Next'

 

وبعد إيقاف تفعيل هذا الأمر ، لن يتجاوز عن الخطأ وسيقف عند الخطأ ويضع عنده لون أصفر (في الكود)

مما سيعطيك فرصة لفهم السبب أو تنقل لنا أين الخطأ بعد تلوينه بالأصفر

[ايهاب سعيد]

بالفعل اخي محمود توقف عند السطر 

  Name pt & nm As pt & "tempo2.xls"

فما السبب

[ايهاب سعيد]

للرفع

[طارق محمود]

السلام عليكم

هذا الأمر يغير إسم الملف الأصلي nm الذي في المسار pt إلي الإسم tempo2.xls الذي في المسار pt أيضا

وهذا في إعتقادي لايعطي خطأ إلا إذا

1- كان الملف nm غير موجود (بالفعل تم تغيير إسمه قبل هذه الخطوة)

2- كان الملف nm مفتوح

 

ولن أستطيع التقرير ، أنت الذي تقرر سبب الخطأ ، تقول

لاحظت ان الكود يعمل ساعات ولا يعمل مرات اخري فما السبب

 

فعليك ملاحظة في أي الحالات بالضبط

وأيضا إرسل لي صورة من الرسالة التي يعطيها مع الخطأ

[ايهاب سعيد]

اخي الفاضل محمود اشكرك علي حسن اهتمام وادعو الله ان يجعله في ميزان حساناتك

اتبعت تعليمات سيادتك ووجدت الخطاء عند السطر

  Kill f_name(i)

يتوقف البرنامج مع ملاحظة ان البرنامج حاليا لا يعمل اطلاقا ولكنه يكون الملف tempo.xls ولا يلغيه