اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

تشغيل الماكرو على مجموعة ملفات في نفس الوقت ، استبدال كلمة فى كل الملفات


الردود الموصى بها

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

اشكر القائمين على هذ المنتدى الاكثر من رائع

كما اشكر الاخ ابو اكرم فهو من قام بعمل هذا الماكرو الموجود عندي الان ..

والسؤال كماهو واضح امامكم (( لدي ماكرو ولدي اكثر من 300 ملف وورد ويلزمني ان افتح كل ملف واشغل الماكرو فاحتاج الى وقت طويل

فهل هناك طريقة بان اشغل الماكرو على جميع الملفات دفعة واحدة)")

وجزاكم الله خير واشكركم مرة اخرى

رابط هذا التعليق
شارك

  • 3 weeks later...

لتشغيل ماكرو معين على أكثر من ملف موجود فى مجلد واحد


Sub ProcessAll()


    Dim Wb As Document, sFile As String, sPath As String

    Dim itm As Variant

    Dim strFileNames  As String


    sPath = "d:\temp2\"


     '    Retrieve the current doc files in directory

    sFile = Dir(sPath & "*.doc")

    Do While sFile <> ""

        strFileNames = strFileNames & "," & sFile

        sFile = Dir()

     Loop


     '  Open each file found

    For Each itm In Split(strFileNames, ",")

        If itm <> "" Then

            Set Wb = Documents.Open(sPath & itm)

            Call addredheader 'this runs my macro from above

            Wb.Close True

        End If

    Next itm


End Sub


مرفق ملف به هذا الكود ، بالاضافة الي ماكرو يقوم باضافة كلمة أوفيسنا موقع الكيرسور أو مكان المؤشر و تغيير لونها و تكبير الخط اسمه addredheader اعددته للتجرية فقط

جرب علي ملفات خالية

حدد مسار الملفات التى تريد التطبيق عليها

ثم شغل الماكرو ProcessAll

سيقوم بتطبيق الماكرو addredheader على كافة الملفات من نوع *.doc داخل المجلد المحدد داخل الكود

وهو هنا فى المثال d:\temp2 كما هو مبين أعلاه

و طبعا ستستبدل الماكرو addredheader بالماكرو الذي تريد تطبيقه

و أخيرا لا تجرب على الملفات الحقيقية

فقط ضع اي ملفات فى المسار d:\temp2 للتجربة ، أو عدل المسار كما تريد

run multi macro.rar

رابط هذا التعليق
شارك

اخي المهندس / محمد

اشكرك جزيل الشكر على هذا العمل الرائع ..

لكن لم اعرف كيف اتصرف مع هذا الماكرو لان معلوماتي بالماكرو قليلة

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

الى اكبر في جميع المستندات

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

وقد ارفقت لك ملف من هذه الملفات الكثير للتطبيق عليه .. وكذالك ارفقت الماكرو الذي لدي للتطبيق

مهل استطيع ان اضيف اكثر من ملف واكثر من مسار

وفقك الله لكل خير وتقبل الله منا ومنك الصيام والقيام وصالح الاعمال

أبو أكرم.rar

سلوك أول.doc

  • Like 1
رابط هذا التعليق
شارك

قمت باضافة الكود الى ملف الأخ ابو اكرم

كما قمت بعمل تعديل فى كوده لتثبيت مسار ملف قاعدة البيانات الى

d:\temp2\Replacements.mdb

حتى ال يسأل عنها فى كل ملف

و الآن قم بما يلي

أعد تسمية قاعدة البيانات باسمReplacements و ضعها فى نفس المسار مع الملفات التي تريد التجربة عليها

أي d:\temp2

و شغل الكود

ProcessAll

فى الملف المرفق كما هو

Replace.rar

  • Thanks 1
رابط هذا التعليق
شارك

قمت باضافة الكود الى ملف الأخ ابو اكرم

كما قمت بعمل تعديل فى كوده لتثبيت مسار ملف قاعدة البيانات الى

d:\temp2\Replacements.mdb

حتى ال يسأل عنها فى كل ملف

ــــــــــــــــــــــــــ

ـــــــــــــــــــــــــ

اخي محمد : اين الكود؟؟

لم تضع الكود بعد التعديل عليه في المرفقات

رابط هذا التعليق
شارك

جر ب مرة أخري

أضفت لك الماكرو أعلى الملف بنفس طريفة أبو أكرم

و حذفت آخر سطرين من الكود الأصلي ، فلم بعد لهما لزوم بعد تثبيت المسار و ربما كان هذا سبب المشكلة

ملاحظة : لقد جربت هذا الملف و عمل معي على جميع الملفات فى المجلد :smile2:

رابط هذا التعليق
شارك

اسأل الله العلي القدير في هذا اليوم يوم الجمعة المباركة ان يبارك لك في علمك وفي عمرك وفي مالك وفي اهلك

وان ييسر لك كل عسير ... واسأله عزوجل ان يوفقك للخير في الدارين ...وان يجعلنا واياك في هذا الشهر من المقبولين

وان يغفر لي ولك ولكل مسلم

اللهم صل وسلم على نبينا محمد وعلى اله وصحبه اجمعين

الان اشتغل تمام

لكن لدي ثلاثة اسئلة :

1ـ يظهر في اخر كل صفحة من المستندات التي اجريت عليها تعديل كلمة ((pAGE )) لااعرف مالسبب؟

2 _ هل استطيع ان اضع اي قاعدة بيانات اخرى في الملف d:\temp2 واضع لها نفس الاسم؟

3 ـ اريد ان اضع اكثر من مسار مثلا اريد ان اضع مع d:\temp2 اضيف d:\temp3 واضيف d:\temp4 وهكذا فماهي الطريقة؟؟

تم تعديل بواسطه المستشار22
رابط هذا التعليق
شارك

يظهر في اخر كل صفحة من المستندات التي اجريت عليها تعديل كلمة ((pAGE )) لااعرف مالسبب؟

هذا غريب ، و لا يظهر لدي ، و لا أعرف سببه ربما تحوي قاعدة البيانات استبدالا لهذه الكلمة

هل تظهر لديك فى الملفات التي ارفقتها سابقا للتطبيق عليها، فهي لا تظهر لدي فيها؟

2

_ هل استطيع ان اضع اي قاعدة بيانات اخرى في الملف d:\temp2 واضع لها نفس الاسم؟

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

3 ـ اريد ان اضع اكثر من مسار مثلا اريد ان اضع مع d:\temp2 اضيف d:\temp3 واضيف d:\temp4 وهكذا فماهي الطريقة؟؟

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

اما اضافة أكثر من مسار فى نفس التطبيق فهذا ممكن و لكن سيتطلب اضافة المسارات ضمن الكود و تعديل الكود فى كل مرة تريد تغيير المسارات فيها ، و يبدو لي الحل الاول أفضل

رابط هذا التعليق
شارك

السلام عليكم

مرفق الملف و الكود و شرح خطواته

ReplaceallInFolder.rar

و يمكنك حذف الثلاثة أسطر الخاصة بكل رسالة اذا لم ترد ظهورها

و هي التي تبدأ ب msgbox




Sub ProcessAll()
' هذا الكود يقوم باختيار فاعدة البيانات التي تحوي كافة اكلمات المراد استبدالها
' ثم اختيار مسار المجلد الموجود به الملفات المطلوب استبدال الكلمات بها
' ثم استدعاء كود الاستبدال ليعمل عليها واحدا تلو الآخر

Dim Wb As Document, sFile As String, sPath As String
Dim itm As Variant
Dim strFileNames, mydbpath As String
Dim f As FileDialog

' اختيار قاعدة البيانات
Set f = Application.FileDialog(msoFileDialogFilePicker)
f.Show
If f.SelectedItems(1) = "" Then
MsgBox "يجب اختيار ملف الاكسيس الذي يحوى الكلمات المطلوب استبدالها "
Exit Sub
End If
mydbpath = f.SelectedItems(1)
MsgBox "سيتم الاستبدال بناء على الملفت الموجودة فى قاعدة البيانات التالية : " & _
Chr(10) & Chr(13) & mydbpath & Chr(10) & Chr(13) & _
" مع تحيات أوفيسنا " & Chr(10) & Chr(13) & "www.officena.net"


' اختيار مسار الملفات المطلوب التطبيق عليها
Set f = Application.FileDialog(msoFileDialogFolderPicker)
f.Show
If f.SelectedItems(1) = "" Then
MsgBox "يجب اختيار مسار المجلد الموجود به الملفات التي تريد التطبيق عليها "
Exit Sub
End If
sPath = f.SelectedItems(1) & "\"

MsgBox "سيتم الاستبدال لطافة ملفات الوورد فى المسار التالي : " & _
Chr(10) & Chr(13) & sPath & Chr(10) & Chr(13) & _
" مع تحيات أوفيسنا " & Chr(10) & Chr(13) & "www.officena.net"

' اختيار مستندات الوورد فقط ضمن الملفات الموجودة فى المجلد
sFile = Dir(sPath & "*.doc")

' ثم استدعاء كود الاستبدال ليعمل عليها واحدا تلو الآخر
Do While sFile <> ""
strFileNames = strFileNames & "," & sFile
sFile = Dir()
Loop

' فتح الملفات و تشغيل كود الاستبدال عليها و احدا تلو الاخر
For Each itm In Split(strFileNames, ",")
If itm <> "" Then
Set Wb = Documents.Open(sPath & itm)
Call Replacedoc(mydbpath) 'استدعاء كود الاستبدال
Wb.Close True
End If
Next itm

End Sub


[/sql]

[sql]

Sub Replacedoc(mydbpath As String)
' هذا الكود يقوم باستبدال كافة الكلمات فى الملف المفتوح طبقا لما ورد فى قاعدة البيانات المحدد اسمها و مسارها فى المتغير

Dim doc As Document
Dim db As DAO.Database
Dim rs As Recordset

Set doc = Application.ActiveDocument
Set db = OpenDatabase(mydbpath)
Set rs = db.OpenRecordset(Name:="Table1")
While Not rs.EOF
With doc.Content.Find
.ClearFormatting
.Text = rs(0)
With .Replacement
.ClearFormatting
.Text = rs(1)
End With
.Execute Replace:=wdReplaceAll, _
Format:=True, MatchCase:=True, _
MatchWholeWord:=True
End With
rs.MoveNext
Wend
rs.Close
db.Close
End Sub


ReplaceallInFolder.rar

  • Like 2
رابط هذا التعليق
شارك

زادك الله علما في امور دينك ودنياك ....وسعادة ...وتوفيقا ...

فلقد اكثرت عليك الاسئلة فلم اجد منك الا سعة الصدر ...وحسن المعاملة

فلقد كنت مثالا في الصبر على المتعلم

بارك الله فيك وفي جهودك في مساعدة اخوانك

واعتذر عن التأخر في الرد بسبب انقطاع الاتصال

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information