أبو عاصم المصري قام بنشر فبراير 5, 2023 مشاركة قام بنشر فبراير 5, 2023 يحتاج الباحث أحيانا إلى استبدال العديد من الكلمات المتباعدة (المتفرقة) في الورد دفعة واحدة، وهذا ماكرو لتنفيذ هذا الأمر. الطريقة: بعد إضافة الماكرو إلى الورد وتشغيل الماكرو: 1- سيظهر لك مربع حوار أول للكلمات التي تريد استبدالها، فتكتبها مفصولة بفاصلة (،) ثم تضغط على (ok) 2- سيظهر مربع الحوار الثاني للكلمات الجديدة، فتكتبها أيضا مفصولة بفاصلة (،) بشرط أن يكون عدد الكلمات في مربع الحوار الثاني مساويا لعدد الكلمات الموجودة في مربع الحوار الأول ثم تضغط على (ok) * النتيجة: سيتم استبدال كل كلمة بما يقابلها مع أن هذه الكلمات متباعدة. وهذا هو الماكرو: Dim xFind As String Dim xReplace As String Dim xFindArr, xReplaceArr Dim i As Long Application.ScreenUpdating = False xFind = InputBox("أدخل هنا مجموعةالكلمات التي تريد استبدالها، مفصولة بفاصلة: ", "الكلمات المطلوب استبدالها") xReplace = InputBox("أدخل الكلمات التي تريد استبدالها مكان السابقة، مفصولة بفاصلة: ", "الكلمات الجديدة") xFindArr = Split(xFind, "،") xReplaceArr = Split(xReplace, "،") If UBound(xFindArr) <> UBound(xReplaceArr) Then MsgBox "يجب التطابق في عدد الكلمات المطلوب استبدالها", vbInformation, "صل على المبعوث رحمة للعالمين" Exit Sub End If For i = 0 To UBound(xFindArr) With Selection.Find .ClearFormatting .Replacement.ClearFormatting .Text = xFindArr(i) .Replacement.Text = xReplaceArr(i) .Format = False .MatchWholeWord = False End With Selection.Find.Execute Replace:=wdReplaceAll Next Application.ScreenUpdating = True Beep End Sub رابط هذا التعليق شارك More sharing options...
مدحت هنداوي قام بنشر يوليو 17, 2023 مشاركة قام بنشر يوليو 17, 2023 جزاكم الله خيراً. هل يمكن تنفيذ نفس الهدف ولكن بحيث يستقي الماكرو قائمتي الكلمات من شيت إكسيل أو قاعدة بيانات أكسيس ؟ أحسن الله إليكم ونفع بكم. 1 رابط هذا التعليق شارك More sharing options...
أبو عاصم المصري قام بنشر يوليو 25, 2023 الكاتب مشاركة قام بنشر يوليو 25, 2023 نعم، لو كنت تريد ذلك من أجل التشكيل، أو ضبط الكلمات، فعندي ماكرو يفيد في ذلك، لو أردتَه أرسلتُه لك. 1 رابط هذا التعليق شارك More sharing options...
مدحت هنداوي قام بنشر يوليو 26, 2023 مشاركة قام بنشر يوليو 26, 2023 في 25/7/2023 at 15:12, أبو عاصم المصري said: نعم، لو كنت تريد ذلك من أجل التشكيل، أو ضبط الكلمات، فعندي ماكرو يفيد في ذلك، لو أردتَه أرسلتُه لك. جزاك الله خيراً أستاذنا على الاهتمام والرد . هل توجد تكلفة مادية لهذا الماكرو ؟ وإن كانت فكم تبلغ ؟ وكيف يمكن التواصل مع حضرتك ؟ نفع الله بكم . 1 رابط هذا التعليق شارك More sharing options...
أبو عاصم المصري قام بنشر يوليو 30, 2023 الكاتب مشاركة قام بنشر يوليو 30, 2023 (معدل) دعوة صالحة... الماكرو يطلب منك أولا فتح ملف مشكول، ويفضل أن تكون المادة العلمية مشابهة للملف المراد تشكيله، بمعنى أنك إذا أردت أن تشكل ملفا في الحديث، فينبغي أن يكون الملف المشكول في الحديث، وإن كان في الفقه فكذلك. ويفضل أيضا أن تبدأ بعدد كلمات أكبر، فتبدأ بست كلمات، ثم خمسة، ثم أربعة،... وهكذا، ليكون التشكيل أدق. ويستحسن في البداية أن تكون المدة قليلة، يعني ابدأ بخمس دقائق، ثم عشرة، وهكذا، لأن برنامج الورد يستهلك قدرا كبيرا من الذاكرة، ويمكن أن يهنج الجهاز. وهذا الماكرو: ' 'تشكيل آلي لكلمة واحدة أو اثنتين حتى ست كلمات، بحيث يبحث الماكرو عن الكلمات غير المشكولة ويقوم بتشكيلها ' ' Dim objDoc As Document '''''' لإغلاق ملفات الورد عدا الذي فيه المؤشر Dim objDocumentsToBeClosed As New Collection Dim nCount As Integer nCount = Application.Documents.count For nIndex = 1 To nCount Set objDoc = Application.Documents.Item(nIndex) If objDoc.FullName <> ActiveDocument.FullName Then objDocumentsToBeClosed.Add objDoc Else Exit For End If Next nIndex For Each objDoc In objDocumentsToBeClosed objDoc.Close SaveChanges:=wdSaveChanges Next objDoc ''''''' Dim xFileDialog As FileDialog, GetStr(1 To 100) As String ' الحد الأقصى (100) ملف Dim xFindStr As String Dim xReplaceStr As String Dim xDoc As Document On Error Resume Next Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker) With xFileDialog .Filters.Clear .Filters.Add "All WORD File ", "*.docx", 1 .AllowMultiSelect = True i = 1 If .Show = -1 Then For Each stiSelectedItem In .SelectedItems GetStr(i) = stiSelectedItem i = i + 1 Next i = i - 1 End If Application.ScreenUpdating = False xFindStr = a xReplaceStr = b For j = 1 To i Step 1 Set xDoc = Documents.Open(FileName:=GetStr(j), Visible:=False) Windows(GetStr(j)).Activate Dim sPrompt As String Dim sUserResp As String Dim iUR As Integer Dim t As Date t = Now Dim StartTime As Date StartTime = Now Do sPrompt = "1. تشكيل كلمة واحدة" & vbCrLf sPrompt = sPrompt & "2. تشكيل كلمتين" & vbCrLf sPrompt = sPrompt & "3. تشكيل ثلاث كلمات" & vbCrLf sPrompt = sPrompt & "4. تشكيل أربع كلمات" & vbCrLf sPrompt = sPrompt & "5. تشكيل خمس كلمات" & vbCrLf sPrompt = sPrompt & "6. تشكيل ثلاث كلمات" & vbCrLf iUR = 0 ''''''''''''''''' While iUR < 1 Or iUR > 6 sUserResp = InputBox(sPrompt, "اختر واحدًا مما يلي") iUR = Val(sUserResp) ''''''''''''''''' لإمكانية إلغاء جميع الاختيارات وقفل الكود If iUR = False Then Exit Sub End If '''''''''''''''''''''' لعمل case لعدة خيارات في InputBox Wend Select Case iUR Case 1 aa = (" <[!ًٍَُِّْ ]@> ") x = (InputBox("اكتب عدد مرات التنفيذ")) y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق")) Case 2 aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>") x = (InputBox("اكتب عدد مرات التنفيذ")) y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق")) Case 3 aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>") x = (InputBox("اكتب عدد مرات التنفيذ")) y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق")) Case 4 aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>") x = (InputBox("اكتب عدد مرات التنفيذ")) y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق")) Case 5 aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>") x = (InputBox("اكتب عدد مرات التنفيذ")) y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق")) Case 6 aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>") x = (InputBox("اكتب عدد مرات التنفيذ")) y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق")) End Select For i = 1 To x If DateDiff("n", StartTime, Now, endTime) = y Then ' s =عدد الثواني ' n =الدقائق ' h =ساعة MsgBox "تم تشكيل الكلمات غير المشكولة وتلوينها باللون البرتقالي" & Format(Now - t, " والوقت المستغرق = h:n:s ") Exit Do Exit Sub ActiveDocument.Save End If Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = aa .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute If Selection.Find.Found = False Then Exit Sub Else End If a = Selection.Text Selection.MoveLeft Unit:=wdCharacter, count:=1 Selection.MoveRight Unit:=wdCharacter, count:=1 Selection.MoveLeft Unit:=wdCharacter, count:=1 Windows(1).Activate Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = a .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = True .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute If Selection.Find.Found = False Then Windows(2).Activate Selection.MoveRight Unit:=wdWord, count:=2 Else b = Selection.Text Selection.MoveRight Unit:=wdCharacter, count:=1 Windows(2).Activate Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Font.Color = 49407 ' اللون البرتقالي With Selection.Find .Text = a .Replacement.Text = b .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = True .MatchAlefHamza = True .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll End If Selection.MoveRight Unit:=wdWord, count:=2 Next i Beep MsgBox "تم تشكيل الكلمات غير المشكولة وتلوينها باللون البرتقالي" & Format(Now - t, " والوقت المستغرق = h:n:s ") Exit Do Exit Sub Loop ActiveDocument.Save Next End With Beep Windows(1).Close (False) '''''' لإغلاق الملف الذي كان يعمل في الخلفية End Sub تم تعديل يوليو 30, 2023 بواسطه أبو عاصم المصري 1 رابط هذا التعليق شارك More sharing options...
مدحت هنداوي قام بنشر يوليو 30, 2023 مشاركة قام بنشر يوليو 30, 2023 جزاك الله خيراً كثيراً . ودعوات بظهر الغيب بإذن الله . 1 رابط هذا التعليق شارك More sharing options...
عبد الله العراقي قام بنشر April 22 مشاركة قام بنشر April 22 (معدل) اخي عاصم ممكن التواصل مع حضرتك لو سمحت تم تعديل April 22 بواسطه عبد الله العراقي 1 رابط هذا التعليق شارك More sharing options...
أبو عاصم المصري قام بنشر April 22 الكاتب مشاركة قام بنشر April 22 تفضل أخي الحبيب رابط هذا التعليق شارك More sharing options...
عبد الله العراقي قام بنشر الثلاثاء at 03:26 مشاركة قام بنشر الثلاثاء at 03:26 (معدل) اخي عاصم حاولت مرارا مع كود استبدال كلمات متعددة اذا ممكن اريدك ان تعيد كتابة هذا الكود من دون توضيحات باللغة العربية يعني كلمات انجليزية خالصة (انا عرفت اماكن وضع الكلمات) اريد الكود خالصا من اي كلمة عربية اريد ان افهم الكود بالدقة لوسمحت تم تعديل الثلاثاء at 03:26 بواسطه عبد الله العراقي رابط هذا التعليق شارك More sharing options...
أبو عاصم المصري قام بنشر الثلاثاء at 06:19 الكاتب مشاركة قام بنشر الثلاثاء at 06:19 أخي الأمر بسيط... سجل ماكرو جديد من قائمة عرض ..... ثم وحدات ماكرو ..... ثم تسجيل ماكرو ..... ثم موافق ..... ثم إيقاف التسجيل. بعد ذلك انسخ الكود (الماكرو) لكن بشرط أن تكون اللغة في الشريط الأسفل (عربي) وذلك قبل النسخ حتى ينسخ الكود كما هو (عربي وإنجليزي). ثم الصق الماكرو، وسيظهر لك الماكرو باللغتين العربي والإنجليزي. رابط هذا التعليق شارك More sharing options...
عبد الله العراقي قام بنشر الثلاثاء at 11:36 مشاركة قام بنشر الثلاثاء at 11:36 اخي ياريت اتواصل معك بوسيلة اسرع غير هذا المتصفح عندي اسئلة كثيرة جدا رابط هذا التعليق شارك More sharing options...
أبو عاصم المصري قام بنشر الأربعاء at 07:26 الكاتب مشاركة قام بنشر الأربعاء at 07:26 أرسلت لك رقم تليفوني للتواصل 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.