كود الترحيل من ملف الى ملف

[bardisse]

اخواني الاعزاء ذوي الخبرة في vba اريد كود لحماية خلية مثلا E2    في شيت 1 لـ 3 ملفات اكسال اي 03 workbook مع العلم ان هذه الملفات بها معلومات مختلفة حيث E2 تمثل اسم المؤسسة لذا اريد كود يحمي الخلية E2 ذات اللون الاصفر  ل 3 ملف في ان واحد عضو جديد ارجو المساعدة جزاكم الله خيرا     تجدون الملف المرفق

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

REMPLIR.rar

[bardisse]

رجو REMPLIR.rar البرمجة و الله انا في امس الحاجة الى هذا العمل لا تبخلوا علينا بالحلول اعانكم الله على الخير

اخواني الاعزاء ذوي الخبرة في vba اريد كود لحماية خلية مثلا E2    في شيت 1 لـ 3 ملفات اكسال اي 03 workbook مع العلم ان هذه الملفات بها معلومات مختلفة حيث E2 تمثل اسم المؤسسة لذا اريد كود يحمي الخلية E2 ذات اللون الاصفر  ل 3 ملف في ان واحد عضو جديد ارجو المساعدة جزاكم الله خيرا     تجدون الملف المرفق

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

Sub ramzi5()
Application.ScreenUpdating = False

 Application.Calculation = xlManual

 Application.EnableEvents = False
Workbooks("SENDRAS.xlsm").Activate
Workbooks("SENDRAS.xlsm").Sheets(1).Range("b1:b" & Cells(Rows.Count, "a").End(xlUp).Row).Copy
Workbooks("01-ÇáäÇÙÑíÉ.xlsm").Activate
x = Range("a" & Rows.Count).End(xlUp).Row
Workbooks("01-ÇáäÇÙÑíÉ.xlsm").Sheets(1).Range("e2").Select
Selection.PasteSpecial xlPasteValues
Workbooks("SENDRAS.xlsm").Activate
[a1].Select
Application.CutCopyMode = False
Workbooks("SENDRAS.xlsm").Activate
Workbooks("SENDRAS.xlsm").Sheets(1).Range("c1:c" & Cells(Rows.Count, "a").End(xlUp).Row).Copy
Workbooks("02-ÇáÚÈÇÓíÉ.xlsm").Activate
x = Range("a" & Rows.Count).End(xlUp).Row
Workbooks("02-ÇáÚÈÇÓíÉ.xlsm").Sheets(1).Range("e2").Select
Selection.PasteSpecial xlPasteValues
Workbooks("SENDRAS.xlsm").Activate
[a1].Select
Application.CutCopyMode = False
Workbooks("SENDRAS.xlsm").Activate
Workbooks("SENDRAS.xlsm").Sheets(1).Range("d1:d" & Cells(Rows.Count, "a").End(xlUp).Row).Copy
Workbooks("03-ÇáãäÕæÑíÉ.xlsm").Activate
x = Range("a" & Rows.Count).End(xlUp).Row
Workbooks("03-ÇáãäÕæÑíÉ.xlsm").Sheets(1).Range("e2").Select
Selection.PasteSpecial xlPasteValues
Workbooks("SENDRAS.xlsm").Activate
[a1].Select

Application.CutCopyMode = False


Application.Calculation = xlAutomatic

Application.EnableEvents = True

Application.ScreenUpdating = True


End Sub

 

من فضلك لا تكرر نفس المشاركان والا ستحذف جميع المشاركات .... يكفيك كتابة للرفع على نفس المشاركة وممنوع كثرة الإلحاح