ماكرو للاستبدال

[asad41163]

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

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

الكلمة الصحيحة باللون الأخضر بجوار الكلمة الخطأ باللون الأحمر ..

مثال: شىء   شيء

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

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

 

المطلوب عمل ماكرو  نظلل الكلميتن مثلا (الخطأ والصواب) : يضع  الكلمة الخطأ في الجزء: البحث عن

ويضع الكلمة الصواب في الجزء: استبدال بـ

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

شكر الله لكم جميعًا...

ملف العمل.txt

[asad41163]

بسم الله الرحمن الرحيم

اللهم علمنا ما ينفعنا وانفعنا بما علمتنا وزدنا علما... آمين

 

أرجو الله تعالى أن ييسر لي المساعدة من أساتذتي الكرام

بارك الله فيكم جميعًا

[عبدالله المجرب]

 

 أو يقوم بالعمل كاملا حسب عدد الكلمات الموجودة..، أيهما أيسر

شكر الله لكم جميعًا...

 

 

اليك الكود اللازم لعمل ذلك

Sub Macro2()
Dim MyFind As String, MyReplac As String
MyFind = InputBox("ضع كلمة البحث", "MyFind")
MyReplac = InputBox("ضع كلمة الإستبدال", "MyReplac")

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = MyFind
        .Replacement.Text = MyReplac
        .Forward = True
        .Wrap = wdFindContinue
        End With
    Selection.Find.Execute
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

[asad41163]

 

 

 أو يقوم بالعمل كاملا حسب عدد الكلمات الموجودة..، أيهما أيسر

شكر الله لكم جميعًا...

 

 

اليك الكود اللازم لعمل ذلك

Sub Macro2()
Dim MyFind As String, MyReplac As String
MyFind = InputBox("ضع كلمة البحث", "MyFind")
MyReplac = InputBox("ضع كلمة الإستبدال", "MyReplac")

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = MyFind
        .Replacement.Text = MyReplac
        .Forward = True
        .Wrap = wdFindContinue
        End With
    Selection.Find.Execute
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

[asad41163]

بسم الله الرحمن الرحيم

الحمد لله والصلاة والسلام على رسول الله

 

الشكر الجزيل للأستاذ عبد الله المجرب المراقب العام بارك الله فيكم 

كما أرجو أن تسمح لي: كيف يمكن أن ينفذ فقط الكلمتين اللتين أقوم بتظليلهما..

[asad41163]

 

 

 

 أو يقوم بالعمل كاملا حسب عدد الكلمات الموجودة..، أيهما أيسر

شكر الله لكم جميعًا...

 

 

اليك الكود اللازم لعمل ذلك

Sub Macro2()
Dim MyFind As String, MyReplac As String
MyFind = InputBox("ضع كلمة البحث", "MyFind")
MyReplac = InputBox("ضع كلمة الإستبدال", "MyReplac")

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = MyFind
        .Replacement.Text = MyReplac
        .Forward = True
        .Wrap = wdFindContinue
        End With
    Selection.Find.Execute
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

 

تم تعديل ديسمبر 11, 2014 بواسطه asad41163

[asad41163]

آسف يا أستاذ عبدالله...، الكود لم يعمل..، 

[الطلحي]

الكود يعمل ، قم بإنشاء ماكرو جديد واحذف جميع ما في النافذة والصق النص واحفظ المستند بامتداد  docm 
 بعد تشغيل الماكرو يظهر لك مربع حواري يطالبك بالكلمة التي تريد استبدالها  ثم يظهر مربع آخر يطالبك بالكلمة التي تريدها، ثم يقوم بتغيير جميع الكلمات المطلوبة في المستند

[asad41163]

الحمد لله سبحانه وتعالى..، أشكرك شكرا جزيلا يا فندم 

 

كنت أتنمنى ألا يوجد مربع حوار.. مثل مربع حوار البحث والاستبدال... لأن عدد الكلمات التي يتم تصحيحها كثير جدا في بروفات الكتب كثير جدا

 

المهم أنني أخذت بعض الإجراءات من بعض الماكروها المتنوعة من النت...

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

Sub ReplaceFromTableL()
Dim ChangeDoc, RefDoc As Document
Dim cTable As Table
Dim oFind, oReplace As Range
Dim i As Long
Dim sFname As String
'Identify the document containing the table of words/phrases and their replacements
sFname = "D:\M_Rajab\changes.docx"
'Identify the document to be processed

WordBasic.TextToTable ConvertFrom:=1, NumColumns:=2, NumRows:=1, _
InitialColWidth:=wdAutoPosition, Format:=0, Apply:=1184, AutoFit:=1, _
SetDefault:=0, Word8:=0, Style:="Table Grid"
ActiveDocument.Tables(1).Borders.Enable = True

Set RefDoc = ActiveDocument
'Open the document with the changes
Set ChangeDoc = Documents.Open(sFname)
'Identify the table to be used
Set cTable = ChangeDoc.Tables(1)
'Activate the document to be processed
RefDoc.Activate
For i = 1 To cTable.Rows.Count
'Identify the cell containing the word/phrase to be replaced
Set oFind = cTable.Cell(i, 1).Range
oFind.End = oFind.End - 1
'Identify the cell containing the replacement word/phrase
Set oReplace = cTable.Cell(i, 2).Range
oReplace.End = oReplace.End - 1
With selection
'Start at the top of the document
.HomeKey wdStory
'Replace the words/phrases
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Execute findText:=oFind, _
ReplaceWith:=oReplace, _
Replace:=wdReplaceAll, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
MatchCase:=True, _
Forward:=True, _
Wrap:=wdFindContinue
End With
End With
Next i
ActiveDocument.Tables(1).Rows(1).Delete
If ActiveDocument.Saved = False Then ActiveDocument.Save
'Close the document with the table
'ChangeDoc.Close wdDoNotSaveChanges
End Sub

 

حياكم الله جميعًا..، والسلام عليكم ورحمة الله وبركاته

[رفعت يسري حامد]

كان هناك ماكرو في هذا الموضوع

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

[عبدالله المجرب]

هل تقصد 

http://www.officena.net/ib/index.php?showtopic=57388&p=364945