שיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.
-
@menajemmendel כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
מה תעשו אם תצטרכו למיין דברים בתוך המאקרו [לקבוע משתנים וכדו'] עצמו לצורך המשך שימשו במאקרו, [ולא דוקא לפי סדר אלפאבתי, אלא לפי כל ערך אחר כגון לסדר תמונות לפי הגודל שלהם, או משהו כזה]? שם אין לכם את כלי המיון של וורד, ואתם חייבים אלגוריתם כמו Bubble Sort. [אגב לפני שבועים היה לי כזה מקרה, ואני לא ידעתי על קיומו של אלגוריטם בועה, וחשבתי על הרבה זמן, איך ניתן לסדר, ובאמת יצא לי משהו מאד דומה לאגוריטם בועה, ואתמול גיליתי את השיטה של בועה, ושאני לא הגאון הראשון.]
עיין כאן נראה שיש להם רעיון משופר
https://stackoverflow.com/a/38298771/23343154שווה גם לחקור את CreateObject יייתכן שאפשר לייבא משהו עם פונקצונליות מובנית
וחשבתי על הרבה זמן, איך ניתן לסדר, ובאמת יצא לי משהו מאד דומה לאגוריטם בועה
עצה טובה לכל אלה שאוהבים לחשוב ולהמציא באמת שכדאי לכם לעשות חיפוש באינטרנט לפני שאתם ממציאים את הגלגל - וגם לפעמים לפני שאתם שואלים את GPT
@pcinfogmach באמת יש הרבה רעיונות יותר טובים יש גם INSERTION SORT וגם QUICKSORT, ובועה היא השיטה הכי פחות יעילה מכולם, והכי איטית, אבל היא גם הכי פשוטה, אז תלוי למה צריך את זה. בכל אופן לא התכוונתי שזה הצורה האופטימלית, אלא שלמטרות למידה זה טוב.
-
מאקרו לבדיקת גודל עמודים ושוליים של המסמך, כלומר לפעמים באמצע המסמך יש שינויים בגודל, ושמים לב לזה רק אחר כל ההשקעה של העימוד ורק בהדפסה רואים את ההבדל, ובוורד המובנה אין אפשרות לראות מה המצב רק במקום שנמצאים עליו, וגם זה רק דרך כניסה לפריסה גודל מותאם אישית וכו', בקיצור אם רוצים לבדוק את כל המסמך בן מאות עמודים יקח הרבה זמן, ועל זה הגיע המאקרו דנן שבודק בלחיצה אחת את כל המסמך, ואם אין שינויים הוא מוציא רק הודעה שכל העמודים בגודל זהה, ואם יש שינויים הוא כותב את כל הפרטים לפי טווחי עמודים.
בהצלחהSub גודל_עמודים_ושוליים_בכל_המסמך() Dim sec As section Dim pageSetup As pageSetup Dim currentWidth As Double Dim currentHeight As Double Dim marginTop As Double Dim marginBottom As Double Dim marginLeft As Double Dim marginRight As Double Dim startPage As Long Dim endPage As Long Dim msg As String Dim totalPages As Long Dim currentSectionIndex As Long Dim lastWidth As Double Dim lastHeight As Double Dim lastTopMargin As Double Dim lastBottomMargin As Double Dim lastLeftMargin As Double Dim lastRightMargin As Double Dim allPagesUniform As Boolean Dim firstRun As Boolean ' הודעת כותרת msg = "מידע על גדלי העמודים והשוליים במסמך (בסנטימטרים):" & vbCrLf totalPages = ActiveDocument.ComputeStatistics(wdStatisticPages) currentSectionIndex = 1 startPage = 1 firstRun = True allPagesUniform = True ' נניח בהתחלה שכולם אחידים ' לולאה לבדוק אם כל העמודים אחידים בגודל ובשוליים Do While startPage <= totalPages If currentSectionIndex > ActiveDocument.Sections.Count Then Exit Do Set sec = ActiveDocument.Sections(currentSectionIndex) Set pageSetup = sec.pageSetup currentWidth = pageSetup.PageWidth / 28.35 ' המרת רוחב לס"מ currentHeight = pageSetup.PageHeight / 28.35 ' המרת גובה לס"מ marginTop = pageSetup.TopMargin / 28.35 ' המרת שוליים עליונים לס"מ marginBottom = pageSetup.BottomMargin / 28.35 ' המרת שוליים תחתונים לס"מ marginLeft = pageSetup.LeftMargin / 28.35 ' המרת שוליים שמאליים לס"מ marginRight = pageSetup.RightMargin / 28.35 ' המרת שוליים ימניים לס"מ ' אם זו הפעם הראשונה, נגדיר את הערכים הראשונים If firstRun Then lastWidth = currentWidth lastHeight = currentHeight lastTopMargin = marginTop lastBottomMargin = marginBottom lastLeftMargin = marginLeft lastRightMargin = marginRight firstRun = False End If ' אם יש שינוי בגודל או בשוליים, העמודים לא אחידים If currentWidth <> lastWidth Or currentHeight <> lastHeight Or _ marginTop <> lastTopMargin Or marginBottom <> lastBottomMargin Or _ marginLeft <> lastLeftMargin Or marginRight <> lastRightMargin Then allPagesUniform = False Exit Do ' אין צורך לבדוק יותר אם העמודים לא אחידים End If ' מעבר לעמוד הבא startPage = startPage + 1 If startPage > ActiveDocument.Sections(currentSectionIndex).Range.Information(wdActiveEndPageNumber) Then currentSectionIndex = currentSectionIndex + 1 If currentSectionIndex > ActiveDocument.Sections.Count Then Exit Do End If Loop ' אם כל העמודים אחידים, הצגת הודעה אחת If allPagesUniform Then MsgBox "כל העמודים במסמך הם בגודל ושוליים זהים.", vbInformation, "מידע על גדלי עמודים ושוליים" Else ' אם יש עמודים שונים, מציגים את כל הנתונים DisplayPageDetails End If End Sub Sub DisplayPageDetails() Dim sec As section Dim pageSetup As pageSetup Dim currentWidth As Double Dim currentHeight As Double Dim marginTop As Double Dim marginBottom As Double Dim marginLeft As Double Dim marginRight As Double Dim startPage As Long Dim endPage As Long Dim msg As String Dim totalPages As Long Dim currentSectionIndex As Long ' הודעת כותרת msg = "מידע על גדלי העמודים והשוליים במסמך (בסנטימטרים):" & vbCrLf totalPages = ActiveDocument.ComputeStatistics(wdStatisticPages) currentSectionIndex = 1 startPage = 1 ' לולאה לבדיקת כל העמודים Do While startPage <= totalPages ' קבלת הגדרות הסעיף הנוכחי If currentSectionIndex > ActiveDocument.Sections.Count Then Exit Do Set sec = ActiveDocument.Sections(currentSectionIndex) Set pageSetup = sec.pageSetup currentWidth = pageSetup.PageWidth / 28.35 ' המרת רוחב לס"מ currentHeight = pageSetup.PageHeight / 28.35 ' המרת גובה לס"מ marginTop = pageSetup.TopMargin / 28.35 ' המרת שוליים עליונים לס"מ marginBottom = pageSetup.BottomMargin / 28.35 ' המרת שוליים תחתונים לס"מ marginLeft = pageSetup.LeftMargin / 28.35 ' המרת שוליים שמאליים לס"מ marginRight = pageSetup.RightMargin / 28.35 ' המרת שוליים ימניים לס"מ ' מציאת טווח עמודים עם אותו גודל ושוליים endPage = startPage Do While endPage <= totalPages If ActiveDocument.Sections(currentSectionIndex).pageSetup.PageWidth <> pageSetup.PageWidth Or _ ActiveDocument.Sections(currentSectionIndex).pageSetup.PageHeight <> pageSetup.PageHeight Or _ ActiveDocument.Sections(currentSectionIndex).pageSetup.TopMargin <> pageSetup.TopMargin Or _ ActiveDocument.Sections(currentSectionIndex).pageSetup.BottomMargin <> pageSetup.BottomMargin Or _ ActiveDocument.Sections(currentSectionIndex).pageSetup.LeftMargin <> pageSetup.LeftMargin Or _ ActiveDocument.Sections(currentSectionIndex).pageSetup.RightMargin <> pageSetup.RightMargin Then Exit Do End If endPage = endPage + 1 If endPage > ActiveDocument.Sections(currentSectionIndex).Range.Information(wdActiveEndPageNumber) Then currentSectionIndex = currentSectionIndex + 1 If currentSectionIndex > ActiveDocument.Sections.Count Then Exit Do End If Loop endPage = endPage - 1 ' הוספת טווח עמודים עם גודל ושוליים להודעה If startPage <= endPage Then msg = msg & "עמודים " & startPage & " עד " & endPage & ":" & vbCrLf msg = msg & " גודל העמוד: " & vbCrLf msg = msg & Format(currentWidth, "0.00") & " x " & Format(currentHeight, "0.00") & " ס''מ" & vbCrLf msg = msg & " שוליים:" & vbCrLf msg = msg & " עליון: " & Format(marginTop, "0.00") & " ס''מ" & vbCrLf msg = msg & " תחתון: " & Format(marginBottom, "0.00") & " ס''מ" & vbCrLf msg = msg & " שמאלי: " & Format(marginLeft, "0.00") & " ס''מ" & vbCrLf msg = msg & " ימני: " & Format(marginRight, "0.00") & " ס''מ" & vbCrLf End If ' מעבר לטווח הבא startPage = endPage + 1 Loop ' הצגת ההודעה בעברית MsgBox msg, vbInformation, "מידע על גדלי עמודים ושוליים" End Sub -
מאקרו שצובע את המילה הראשונה של כל עמוד בירוק ואת המילה האחרונה באדום, נצרך מאוד לתיקונים לאחר עימוד כדי לוודא שלא קפצו מילים לעמוד הבא.
ויש לחצן לבדיקת המסמך בסיום העבודה לפני סגירה לדפוס אם יש סימונים שהוזזו ממקומם בתחילת העמוד, אם הכל בסדר מוציא הודעה על כך.
ולחצן נוסף למחיקת הסימונים לאחר שהכל תקין [הצבעים שנצבעים הם לא שגרתיים כך שאין לחשוש שימחקו סימונים אחרים שצריכים לישאר].Sub סימון_תחילת_וסוף_עמוד() On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות Dim doc As Document Dim rng As Range Dim pageCount As Integer Dim i As Integer Dim firstWord As Range Dim lastWord As Range Dim secondLastWord As Range Dim lastWordEnd As Long Dim firstWordEnd As Long Dim hasPunctuation As Boolean Application.UndoRecord.StartCustomRecord ' קבלת המסמך הפעיל Set doc = ActiveDocument pageCount = doc.ComputeStatistics(wdStatisticPages) ' מעבר על כל עמוד במסמך For i = 1 To pageCount ' הגדרת טווח העמוד Set rng = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i) rng.End = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1).Start rng.End = rng.End - 1 ' להוציא את הסימן של עמוד חדש ' סימון המילה הראשונה Set firstWord = rng.Words(1) firstWordEnd = firstWord.End firstWord.font.Color = RGB(1, 255, 1) ' צבע ירוק בהיר ' סימון המילה האחרונה Set lastWord = rng.Words(rng.Words.Count) lastWordEnd = lastWord.End ' בדוק אם יש סימן פיסוק בסוף המילה האחרונה hasPunctuation = InStr(".!?," & Chr(34), Mid(lastWord.Text, Len(lastWord.Text), 1)) > 0 If hasPunctuation Then ' אם יש סימן פיסוק, צובע את שתי המילים האחרונות If rng.Words.Count > 1 Then Set secondLastWord = rng.Words(rng.Words.Count - 1) secondLastWord.font.Color = RGB(255, 1, 1) ' צבע אדום בהיר End If lastWord.font.Color = RGB(255, 1, 1) ' צבע אדום בהיר Else ' אם אין סימן פיסוק, צובע רק את המילה האחרונה lastWord.font.Color = RGB(255, 1, 1) ' צבע אדום בהיר End If Next i MsgBox "המאקרו הסתיים בהצלחה!", vbInformation Application.UndoRecord.EndCustomRecord Exit Sub ErrorHandler: Application.UndoRecord.EndCustomRecord MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה" End Sub Sub חיפוש_סימונים_שלא_במקומם() Static currentPage As Integer Static errorsFound As Boolean Dim doc As Document Dim rng As Range Dim pageCount As Integer Dim i As Integer Dim firstWord As Range Dim startOfPageColor As Long ' צבע לבדיקה startOfPageColor = RGB(1, 255, 1) ' ירוק בהיר ' אתחול משתנים Set doc = ActiveDocument pageCount = doc.ComputeStatistics(wdStatisticPages) ' התחלת בדיקה מהעמוד הראשון אם זה ההפעלה הראשונה If currentPage = 0 Then currentPage = 1 errorsFound = False ' איפוס מצב שגיאות End If ' מעבר על עמודים מהעמוד הנוכחי עד סוף המסמך For i = currentPage To pageCount ' הגדרת טווח עמוד Set rng = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, count:=i) rng.End = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, count:=i + 1).Start - 1 ' בדיקה אם יש מילים בעמוד If rng.Words.count > 0 Then ' קבלת המילה הראשונה בדיוק מתחילת העמוד Set firstWord = rng.Words(1) If firstWord.Information(wdActiveEndPageNumber) = i Then ' בדיקת צבע המילה הראשונה If firstWord.font.Color <> startOfPageColor Then firstWord.Select errorsFound = True ' נמצאה שגיאה currentPage = i + 1 ' שמירת המיקום להמשך החיפוש Exit Sub End If End If End If Next i ' אם הגענו לסוף המסמך If errorsFound Then MsgBox "החיפוש הסתיים, לא נמצאו עמודים נוספים שהשתנו", vbInformation Else MsgBox "החיפוש הסתיים ולא נמצאו עמודים שהשתנו", vbInformation End If ' איפוס המיקום והסטטוס לבדיקות חדשות currentPage = 0 errorsFound = False End Sub Sub הסרת_הצבעים_המיוחדים() On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות Dim doc As Document Dim rng As Range Dim i As Integer Dim word As Range ' קבלת המסמך הפעיל Set doc = ActiveDocument ' מעבר על כל המילים במסמך For Each rng In doc.StoryRanges Do For Each word In rng.Words ' אם הצבע אדום בהיר או ירוק בהיר, נסיר אותו If word.font.Color = RGB(1, 255, 1) Or word.font.Color = RGB(255, 1, 1) Then word.font.Color = wdColorAutomatic End If Next word Set rng = rng.NextStoryRange Loop While Not rng Is Nothing Next rng MsgBox "הצבעים הוסרו בהצלחה!", vbInformation Exit Sub ErrorHandler: MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה" End Subעריכה: לבקשת @שלמה11 כאן שיניתי את הצבעים ללא רגילים כדי שיהיה אפשרות להסרה קלה.
נוסף לחצן לבדיקת כל המסמך אם כל הסימנים נשארו במקומם הנכון.
וכן נוסף לחצן להסרת הצבעים.
כמו כן נוסף אפשרות לבטל דרך קונטרול z. ועוד שיפורים@מניין כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
מאקרו שצובע את המילה הראשונה של כל עמוד בירוק ואת המילה האחרונה באדום, נצרך מאוד לתיקונים לאחר עימוד כדי לוודא שלא קפצו מילים לעמוד הבא.
אולי כדאי לצבוע את המילה הראשונה/האחרונה לא בצבע אדום/ירוק רגיל אלא:
Font.Color = RGB(255, 1, 1)
Font.Color = RGB(1, 255, 1)
ואז יהיה אפשר לעשות מאקרו של הסרה, מבלי לפגוע בטקסטים אחרים שצבועים באדום/ירוק -
@מניין כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
מאקרו שצובע את המילה הראשונה של כל עמוד בירוק ואת המילה האחרונה באדום, נצרך מאוד לתיקונים לאחר עימוד כדי לוודא שלא קפצו מילים לעמוד הבא.
אולי כדאי לצבוע את המילה הראשונה/האחרונה לא בצבע אדום/ירוק רגיל אלא:
Font.Color = RGB(255, 1, 1)
Font.Color = RGB(1, 255, 1)
ואז יהיה אפשר לעשות מאקרו של הסרה, מבלי לפגוע בטקסטים אחרים שצבועים באדום/ירוק@שלמה11 כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
@מניין כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
מאקרו שצובע את המילה הראשונה של כל עמוד בירוק ואת המילה האחרונה באדום, נצרך מאוד לתיקונים לאחר עימוד כדי לוודא שלא קפצו מילים לעמוד הבא.
אולי כדאי לצבוע את המילה הראשונה/האחרונה לא בצבע אדום/ירוק רגיל אלא:
Font.Color = RGB(255, 1, 1)
Font.Color = RGB(1, 255, 1)
ואז יהיה אפשר לעשות מאקרו של הסרה, מבלי לפגוע בטקסטים אחרים שצבועים באדום/ירוקעודכן כאן בתוספת מאקרו להסרה
-
מ מניין התייחס לנושא זה
-
מאקרו שמחזיר לטור אחד לפי סוג כותרת [משוכלל הרבה יותר מהמאקרו הקודם שמחזיר רק לפי מרכוז], יש אפשרות להחיל את המאקרו רק על פיסקא אחת או על כל המסמך, ומוחק כל המעברים המיותרים.
הוראות:- קודם כל צריך לפרוס את כל המסמך לשני טורים ולכוון את המרווחים.
- לוחצים על הלחצן 'מחזיר לטור אחד לפי כותרת' ושואל איזה סגנון רוצים להחזיר לטור אחד.
- שואל אם רוצים רק על פיסקא אחת או על כל המסמך, וכמובן אפשר ללחוץ על ביטול.
- המאקרו מנקה אוטומטי את כל סוגי הכפילויות שנוצרות בגלל הפעולה.
- אם רוצים אפשר לבטל הכל בלחיצה על קונטרול Z.
- יש אפשרות לעשות את הפעולה גם על כמה סגנונות בכל פעם על סגנון אחר או לחזור על אותו סגנון, והמאקרו מוחקת כל הכפילויות.
- אם רוצים להסיר ולהחזיר לשני טורים, יש לחצן נוסף 'מבטל פסקאות שעוצבו לטור אחד ומחזיר לשני טורים', יש שאלת בחירה לאחת משתי אפשרויות, או לבטל במקום אחד, או לבטל הכל בכל המסמך [במקרה שהסתבך, גם בזה יש אפשרות ביטול בלחיצה אחת קונטרול Z].
Sub מחזיר_לטור_אחד_לפי_כותרת() Dim Alerts As Boolean Dim a As Boolean Dim headingName As String Dim para As paragraph Dim section As section Dim inSelectedHeading As Boolean Dim userChoice As VbMsgBoxResult Dim deleteParagraphBreaks As VbMsgBoxResult On Error GoTo ErrorHandler Application.UndoRecord.StartCustomRecord "החזרת לטור אחד לפי כותרת" Alerts = Application.DisplayAlerts Application.DisplayAlerts = wdAlertsNone Application.ScreenUpdating = False headingName = InputBox("הזן את שם הכותרת שברצונך לשנות לטור אחד:", "בחירת כותרת") If headingName = "" Then MsgBox "לא הוזנה כותרת. הפעולה בוטלה.", vbExclamation Exit Sub End If userChoice = MsgBox("האם ברצונך להחיל את השינוי על כל המסמך?", vbYesNoCancel + vbQuestion, "בחירת היקף פעולה") If userChoice = vbCancel Then MsgBox "הפעולה בוטלה.", vbExclamation Exit Sub End If If userChoice = vbNo Then Selection.MoveDown Unit:=wdParagraph, count:=1 Else Selection.HomeKey Unit:=wdStory End If Do Selection.Find.ClearFormatting With Selection.Find .Style = headingName .Text = "^$" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With a = Selection.Find.Execute If a = True Then Selection.Paragraphs(1).Range.Select ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Start). _ InsertBreak Type:=wdSectionBreakContinuous Selection.Start = Selection.Start + 1 ActiveDocument.Range(Start:=Selection.End, End:=Selection.End).InsertBreak _ Type:=wdSectionBreakContinuous With Selection.pageSetup.TextColumns .SetCount numColumns:=1 .EvenlySpaced = True .LineBetween = False End With Selection.MoveRight Unit:=wdCharacter, count:=1 End If Loop While a = True And (userChoice = vbYes) Call מחיקת_מעברים_מיותרים Selection.HomeKey Unit:=wdStory MsgBox "הפעולה הושלמה! ניתן לבטל את כל השינויים באמצעות Ctrl+Z.", vbInformation Cleanup: Application.DisplayAlerts = Alerts Application.ScreenUpdating = True Application.UndoRecord.EndCustomRecord Exit Sub ErrorHandler: MsgBox "אירעה שגיאה: " & Err.Description, vbCritical Resume Cleanup End Sub Private Sub מחיקת_מעברים_מיותרים() Dim sectionBreakRange As Range Dim paraBefore As Range Dim paraAfter As Range Application.ScreenUpdating = False Selection.HomeKey Unit:=wdStory If Selection.Find.Execute(FindText:="^b", MatchWildcards:=False, Forward:=True, Wrap:=wdFindStop) = True Then If Selection.Start = 0 Then Selection.Delete End If End If Dim found As Boolean Dim specialChar As String: specialChar = ";~;" Selection.HomeKey Unit:=wdStory With Selection.Find .ClearFormatting: .Text = "^b^b": .Forward = True: .Wrap = wdFindStop: .Format = False: .MatchWildcards = False End With Do While Selection.Find.Execute Selection.Collapse Direction:=wdCollapseEnd: Selection.TypeText Text:=specialChar Loop Selection.HomeKey Unit:=wdStory With Selection.Find .ClearFormatting: .Text = "^b" & specialChar: .Forward = True: .Wrap = wdFindStop: .Format = False: .MatchWildcards = False End With Do While Selection.Find.Execute Selection.Delete Loop Selection.HomeKey Unit:=wdStory With Selection.Find .ClearFormatting: .Text = specialChar: .Forward = True: .Wrap = wdFindStop: .Format = False: .MatchWildcards = False End With Do While Selection.Find.Execute Selection.Delete Loop Selection.HomeKey Unit:=wdStory Do While Selection.Find.Execute(FindText:="^b", MatchWildcards:=False, Forward:=True, Wrap:=wdFindStop) = True Set sectionBreakRange = Selection.Range If sectionBreakRange.Start > 0 Then On Error Resume Next Set paraBefore = sectionBreakRange.Paragraphs(1).Range.Previous(wdParagraph, 1) Set paraAfter = sectionBreakRange.Paragraphs(1).Range.Next(wdParagraph, 1) On Error GoTo 0 If Not paraBefore Is Nothing And Not paraAfter Is Nothing Then If paraBefore.pageSetup.TextColumns.count = 1 And _ paraAfter.pageSetup.TextColumns.count = 1 Then sectionBreakRange.Delete End If End If End If Selection.Start = sectionBreakRange.Start Selection.Collapse Direction:=wdCollapseEnd Loop Application.ScreenUpdating = True End Sub Sub מבטל_פסקאות_שעוצבו_לטור_אחד_ומחזיר_לשני_טורים() On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות Dim userChoice As VbMsgBoxResult userChoice = MsgBox("מחזיר פיסקא נוכחית לשני טורים. האם ברצונך לעשות פעולה זו על כל המסמך?", vbYesNo + vbQuestion, "מחיקת מעברי מקטע") If userChoice = vbYes Then Call מחיקת_מעברי_מקטע_בכל_המסמך ElseIf userChoice = vbNo Then Call מחיקת_מעברי_מקטע_בפסקא_נוכחית Else MsgBox "הפעולה בוטלה.", vbInformation End If Exit Sub ErrorHandler: MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה" End Sub Private Sub מחיקת_מעברי_מקטע_בכל_המסמך() On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות Dim para As paragraph Dim paraRange As Range Dim sectionRange As Range Application.UndoRecord.StartCustomRecord Application.ScreenUpdating = False Selection.HomeKey Unit:=wdStory For Each para In ActiveDocument.Paragraphs Set paraRange = para.Range If paraRange.pageSetup.TextColumns.count = 1 Then Set sectionRange = paraRange.Duplicate sectionRange.Collapse wdCollapseEnd sectionRange.MoveEnd Unit:=wdCharacter, count:=1 If sectionRange.Text = Chr(12) Then sectionRange.Delete With ActiveDocument.Range(paraRange.Start - 1, paraRange.Start) If .Text = Chr(12) Then .Delete End If End With End If End If Next para MsgBox "הפעולה הסתיימה בהצלחה על כל המסמך", vbInformation Application.ScreenUpdating = True Application.UndoRecord.EndCustomRecord Exit Sub ErrorHandler: Application.ScreenUpdating = True Application.UndoRecord.EndCustomRecord MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה" End Sub Private Sub מחיקת_מעברי_מקטע_בפסקא_נוכחית() On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות Dim currentPara As paragraph Dim paraRange As Range Dim sectionRange As Range Application.UndoRecord.StartCustomRecord Application.ScreenUpdating = False If Selection.Range.Paragraphs.count = 0 Then MsgBox "נא לעמוד בתוך פסקה בטור אחד.", vbExclamation GoTo Cleanup End If Set currentPara = Selection.Range.Paragraphs(1) Set paraRange = currentPara.Range If currentPara.Range.pageSetup.TextColumns.count <> 1 Then MsgBox "נא לעמוד בפסקה בטור אחד בלבד.", vbExclamation GoTo Cleanup End If Set sectionRange = paraRange.Duplicate sectionRange.Collapse wdCollapseEnd sectionRange.MoveEnd Unit:=wdCharacter, count:=1 If sectionRange.Text <> Chr(12) Then MsgBox "נא לעמוד בפסקה האחרונה לפני מעבר לשני טורים.", vbExclamation GoTo Cleanup End If sectionRange.Delete With Selection.Find .ClearFormatting .Text = "^b" .Forward = False .Wrap = wdFindStop If .Execute Then Selection.Delete End With MsgBox "הפעולה הושלמה בהצלחה עבור הפסקה הנוכחית", vbInformation Cleanup: Application.ScreenUpdating = True Application.UndoRecord.EndCustomRecord Exit Sub ErrorHandler: Application.ScreenUpdating = True Application.UndoRecord.EndCustomRecord MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה" End Subשוה בדיקה
עריכה: הוכנסו שני תיקונים במאקרו, יש להוריד מחדש.
עריכה נוספת: נוסף אפשרות לשחזר את כל השינויים בלחיצה אחת על Ctrl+Z
עריכה שלישית: נוסף לחצן להסרת הפעולה, כשאין אפשרות של ביטול פעולה אחרונה, ועוד הרבה שיפורים למניעת שגיאות של כפילויות וכדו', וכן הוראות הפעלה@מניין אני רואה שבכמה מאקרו אתה מוסיף את האפשרות של ביטול פעולה אחרונה, וזה מאד עוזר, אבל חשוב מאד, לדעת שאם אתה מוסיף את זה אז עוד יותר חשוב להוסיף גם error handeling, כמו שהסברתי כאן (אחרת עלול לגרום לבעיות שאחריתם מי ישורנו)
-
@מניין אני רואה שבכמה מאקרו אתה מוסיף את האפשרות של ביטול פעולה אחרונה, וזה מאד עוזר, אבל חשוב מאד, לדעת שאם אתה מוסיף את זה אז עוד יותר חשוב להוסיף גם error handeling, כמו שהסברתי כאן (אחרת עלול לגרום לבעיות שאחריתם מי ישורנו)
@menajemmendel כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
@מניין אני רואה שבכמה מאקרו אתה מוסיף את האפשרות של ביטול פעולה אחרונה, וזה מאד עוזר, אבל חשוב מאד, לדעת שאם אתה מוסיף את זה אז עוד יותר חשוב להוסיף גם error handeling, כמו שהסברתי כאן (אחרת עלול לגרום לבעיות שאחריתם מי ישורנו)
-
מ מניין התייחס לנושא זה
-
בס"ד
פוסט מסודר עבור העלאת מאקרואים לוורד
הנחיות עבור עורכי פוסטים
כל מי שיכול להעלות מאקרואים לתועלת הציבור נא להעלות כאן
תגובות לנושא זה יש לכתוב כאן בשרשור התגובות כמו"כ ניתן למצוא הוראות נוספות להכנת מאקרו בשרשור התגובות.שים לב! שרשור זה נועד עבור המשתמש הפשוט לכן אבקש מכולם נא לא להעלות כאן קודים אלא רק מאקרו מוכן בתוך תבנית - כדי שכולם יוכלו להשתמש בהם בקלות. כפי שיפורט להלן, מאוד קל להתקין בוורד מאקרו מוכן באופן זה.
להוראות כיצד להכין תבנית עם מאקרו לחץ כאן
מי שיכול אבקש ממנו שיכין את המאקרו בתוך קובץ לחילוץ עצמי שיחלץ את הקבצים למקום הראוי%AppData%/Microsoft/Word/STARTUP
עיין כאן להוראות איך מכינים קובץ לחילוץ עצמי
תוכן העניינים
תוכן העניינים אינו כולל הכול ומעדכן מידי פעם.
- מאקרו יישור טורים בוורד
- מאקרו תיקון שגיאות נפוצות
- תבנית מחיקת פסקאות ריקות ורווח לפני פסקא
- הערות ברצף
- שילוב של כמה מאקרוים: (הקטנת והגדלת סוגריים על כל המסמך. עריכת הפניות מקושרות. עדכון הפניות מקושרות. מעבר בין מקטעים. המרת הפניות לתג).
- סימון שגיאה בטקסט על ידי ..?
- תיקון שגיאות מנצפך ועוד שיבושים נוספים
- עיצוב ספרי קודש
- עיצוב אוטומטי של ההערות שוליים כנהוג ברוב ספרי הקודש
- חיפוש והחלפה פרטניים
- עיצוב כל כותרות בטור אחד במסמך של שני טורים
- מעבר עמוד לפני כותרת
- מאקרו שמוסיף שדה למיספור אוטומטי (שימושי מאוד לספר עם סימנים רבים, ובכל סימן יש סעיפים)
- מאקרו מעבר מהערה למסמך ולהיפך, וכן מאקרו ליצירת אינדקס בקלות
- קוד VBA להמיר בוורד ממספרים לאותיות, רגיל ובלשון נקייה.
- שינוי מרווח טורים רק בהערות שוליים
- החלפת שדה נבחר למספור אוטומטי אותיות
- המרת מספרים לאותיות עם לשון נקיה
- חיפוש ותיקון סוגריים לא סגורים
- תיקון סוגריים גירסה 2 - מאקרו לגיבוי התבנית normal (הגדרות ברירת המחדל)
- חילוץ טקסט - מפרק את כל ההערות שבמסמך [בלון, שוליים, הערות] למסמכים נפרדים, ומשאיר הפניות במסמך המקורי, עיצוב לבחירת המשתמש.
- מאקרו לוורד להצגת כל קיצורי המקשים המותאמים אישית: - והתבנית המוכנה כאן: https://mitmachim.top/post/641294
- החלפת אות, מילה, או פיסקה עם הסמוכה לה
- הערות שולים - מספור בעברית עד 1200
- קבלת הקוד של התיו המסומן לתורך שימוש בחיפוש והחלפה
- פתרון באג שצג
- המרה הוספה ועריכה שדה מספור אוטומטי
- מספור עברי מעל שצב
- חיפוש והחלפה באבני בניין
- מאקרו הפניה מקושרת אינדקס תצוגת טויטה.
- מאקרו שצובע את המילה הראשונה של כל עמוד בירוק ואת המילה האחרונה באדום, נצרך מאוד לתיקונים לאחר עימוד כדי לוודא שלא קפצו מילים לעמוד הבא.
- מאקרו הדפסה לפי רשימה
- מאקרו להסתרת טקסט
- הפניה מקושרת ממסמך למסמך
- הוספת עיטור לפני או אחרי כותרת
- מאקרו צמצום מסמך בוורד
- מאקרו איזון שורה אחרונה - מילה אחרונה תלושה
הוראות להתקנת מאקרו בקלות
להוראות כלליות לגבי מאקרו ניתן לעיין כאן
כדי להתקין מאקרו בוורד בקלות
-
יש להוריד את התבנית הרצויה (תבניות יובאו בפוסטים בהמשך השרשור)
-
יש להעתיק את התבנית אל תוך התיקייה הזו:
AppData%\Microsoft\Word\STARTUP%
(אפשר ללחוץ על "מקש-חלונות + R" ולהזין שם את הכתובת הנ"ל)
- רוצים להסיר מאקרו? פשוט מחקו אותו מהתיקייה הנ"ל.
אפשרות התקנה חילופית:
יש לפתוח את המאקרו ולאחמ"כ יש לעבור ללשונית 'תצוגה', בצד שמאל יש ללחוץ על 'פקודות מאקרו', בחלון שנפתח יש ללחוץ בצד שמאל על 'סדרן' ולהעתיק את המאקרו מהחלונית הימנית לשמאלית, להעברת המאקרו לתבנית נורמל (Normal).
כדי למחוק מאקרו שהותקן בצורה זו יש לבחור במחק שבחלון זה.-
כעת המאקרו שבתבנית יהיו זמינים לכם בכל מסמך שתרצו
-
כדי להריץ מאקרו יש להיכנס לכרטיססית תצוגה בוורד > פקודות מאקרו > הצג פקודות מאקרו ( או ללחוץ ALT +F8).
כעת בחרו במאקרו המתאים ולחצו על הפעל.
איך ליצור קיצורי דרך למאקרו בקלות
אפשר גם ליצור קיצורי דרך (קיצורי מקשים או לחצן) עבור כל מאקרו שתירצו וכדלהלן:
כדי ליצור קיצור מקשים:
היכנס לקובץ> אפשרויות> התאמה אישית של רצועת הכלים לחץ על 'קיצורי המקלדת' שבתחתית החלון מצד ימין.
או: לחץ על החץ הקטן שבסרגל הכלים לגישה מהירה > אפשרויות> התאמה אישית של רצועת הכלים לחץ על 'קיצורי המקלדת' שבתחתית החלון מצד ימין.
כעת יש לגלול ב'קטגוריות' לתחתית החלון ולסמן את פקודות מאקרו - כאן תוכלו להזין איזה קיצור מקשים שתירצו רק שימו לב לכיתוב שמופיע תחת החלון בצד ימין מוקצה כרגע ל: הוי אומר שהקיצור שבחרתם כבר מוקצה למשהו אחר ועלכים להחליט אם לדרוס הקצאה זו או לא
כדי ליצור לחצן:
היכנסו כנ"ל אל אפשרויות וורד
כעת עליכם להחליט אם ליצור לחצן בסרגל הכלים לגישה מהירה, או ליצור סרגל חדש ב 'התאמה אישית של רצועת הכלים' (או אולי סתם להוסיף את המאקרו לסרגל קיים).
החלטתם!
כעת תחת 'בחר פקודות מתוך' בחרו ב'פקודות מאקרו' והוסיפו את הפקודות שברצונכם ליצור להם לחצן על ידי 'הוסף' שבמרכז החלון.
אם ברצונכם שהלחצן יהיה מעוצב קצת - סמנו את לחצן המאקרו שהוספתם ולחצו על 'שינוי' (בצד ימין למטה)בהצלחה!
@pcinfogmach מצורף מאקרו תיקון שגיאות - קצת שונה ממה שכבר העלת כאן מ @א.מ
מכיוון שאני לא יודע איך סוגרים אותו, וגם בכדי שיכולו לעבור עליו - אני מצרף אותו גם בתוך קובץ TXT.
(יש שם כמה דברים שמיועדים למי שמשתמש עם תיקון שגיאות אוטומטי (https://mitmachim.top/topic/78023/להורדה-תיקון-שגיאות-אוטומטי-בוורד/19)||Sub תיקון_סימנים_כפולים()
'
' תיקון_סימנים_כפולים Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ".."
.Replacement.Text = "."
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = ",,"
.Replacement.Text = ","
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "''"
.Replacement.Text = "'"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = " "
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = " ,"
.Replacement.Text = ","
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = " ."
.Replacement.Text = "."
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = " """
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = """"""
.Replacement.Text = """"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "ייי"
.Replacement.Text = "יי"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End WithSelection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Font.Color = wdColorRed With Selection.Find .Text = "^$צ " .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "^$מ " .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "^$פ " .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "^$נ " .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "^$כ " .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End Wit Selection.Find.Execute Replace:=wdReplaceAll||ספויילר
אשמח לשיפורים, הערות, והארות
-
מאקרו שצובע את המילה הראשונה של כל עמוד בירוק ואת המילה האחרונה באדום, נצרך מאוד לתיקונים לאחר עימוד כדי לוודא שלא קפצו מילים לעמוד הבא.
ויש לחצן לבדיקת המסמך בסיום העבודה לפני סגירה לדפוס אם יש סימונים שהוזזו ממקומם בתחילת העמוד, אם הכל בסדר מוציא הודעה על כך.
ולחצן נוסף למחיקת הסימונים לאחר שהכל תקין [הצבעים שנצבעים הם לא שגרתיים כך שאין לחשוש שימחקו סימונים אחרים שצריכים לישאר].Sub סימון_תחילת_וסוף_עמוד() On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות Dim doc As Document Dim rng As Range Dim pageCount As Integer Dim i As Integer Dim firstWord As Range Dim lastWord As Range Dim secondLastWord As Range Dim lastWordEnd As Long Dim firstWordEnd As Long Dim hasPunctuation As Boolean Application.UndoRecord.StartCustomRecord ' קבלת המסמך הפעיל Set doc = ActiveDocument pageCount = doc.ComputeStatistics(wdStatisticPages) ' מעבר על כל עמוד במסמך For i = 1 To pageCount ' הגדרת טווח העמוד Set rng = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i) rng.End = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1).Start rng.End = rng.End - 1 ' להוציא את הסימן של עמוד חדש ' סימון המילה הראשונה Set firstWord = rng.Words(1) firstWordEnd = firstWord.End firstWord.font.Color = RGB(1, 255, 1) ' צבע ירוק בהיר ' סימון המילה האחרונה Set lastWord = rng.Words(rng.Words.Count) lastWordEnd = lastWord.End ' בדוק אם יש סימן פיסוק בסוף המילה האחרונה hasPunctuation = InStr(".!?," & Chr(34), Mid(lastWord.Text, Len(lastWord.Text), 1)) > 0 If hasPunctuation Then ' אם יש סימן פיסוק, צובע את שתי המילים האחרונות If rng.Words.Count > 1 Then Set secondLastWord = rng.Words(rng.Words.Count - 1) secondLastWord.font.Color = RGB(255, 1, 1) ' צבע אדום בהיר End If lastWord.font.Color = RGB(255, 1, 1) ' צבע אדום בהיר Else ' אם אין סימן פיסוק, צובע רק את המילה האחרונה lastWord.font.Color = RGB(255, 1, 1) ' צבע אדום בהיר End If Next i MsgBox "המאקרו הסתיים בהצלחה!", vbInformation Application.UndoRecord.EndCustomRecord Exit Sub ErrorHandler: Application.UndoRecord.EndCustomRecord MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה" End Sub Sub חיפוש_סימונים_שלא_במקומם() Static currentPage As Integer Static errorsFound As Boolean Dim doc As Document Dim rng As Range Dim pageCount As Integer Dim i As Integer Dim firstWord As Range Dim startOfPageColor As Long ' צבע לבדיקה startOfPageColor = RGB(1, 255, 1) ' ירוק בהיר ' אתחול משתנים Set doc = ActiveDocument pageCount = doc.ComputeStatistics(wdStatisticPages) ' התחלת בדיקה מהעמוד הראשון אם זה ההפעלה הראשונה If currentPage = 0 Then currentPage = 1 errorsFound = False ' איפוס מצב שגיאות End If ' מעבר על עמודים מהעמוד הנוכחי עד סוף המסמך For i = currentPage To pageCount ' הגדרת טווח עמוד Set rng = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, count:=i) rng.End = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, count:=i + 1).Start - 1 ' בדיקה אם יש מילים בעמוד If rng.Words.count > 0 Then ' קבלת המילה הראשונה בדיוק מתחילת העמוד Set firstWord = rng.Words(1) If firstWord.Information(wdActiveEndPageNumber) = i Then ' בדיקת צבע המילה הראשונה If firstWord.font.Color <> startOfPageColor Then firstWord.Select errorsFound = True ' נמצאה שגיאה currentPage = i + 1 ' שמירת המיקום להמשך החיפוש Exit Sub End If End If End If Next i ' אם הגענו לסוף המסמך If errorsFound Then MsgBox "החיפוש הסתיים, לא נמצאו עמודים נוספים שהשתנו", vbInformation Else MsgBox "החיפוש הסתיים ולא נמצאו עמודים שהשתנו", vbInformation End If ' איפוס המיקום והסטטוס לבדיקות חדשות currentPage = 0 errorsFound = False End Sub Sub הסרת_הצבעים_המיוחדים() On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות Dim doc As Document Dim rng As Range Dim i As Integer Dim word As Range ' קבלת המסמך הפעיל Set doc = ActiveDocument ' מעבר על כל המילים במסמך For Each rng In doc.StoryRanges Do For Each word In rng.Words ' אם הצבע אדום בהיר או ירוק בהיר, נסיר אותו If word.font.Color = RGB(1, 255, 1) Or word.font.Color = RGB(255, 1, 1) Then word.font.Color = wdColorAutomatic End If Next word Set rng = rng.NextStoryRange Loop While Not rng Is Nothing Next rng MsgBox "הצבעים הוסרו בהצלחה!", vbInformation Exit Sub ErrorHandler: MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה" End Subעריכה: לבקשת @שלמה11 כאן שיניתי את הצבעים ללא רגילים כדי שיהיה אפשרות להסרה קלה.
נוסף לחצן לבדיקת כל המסמך אם כל הסימנים נשארו במקומם הנכון.
וכן נוסף לחצן להסרת הצבעים.
כמו כן נוסף אפשרות לבטל דרך קונטרול z. ועוד שיפורים@מניין כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
Sub הסרת_הצבעים_המיוחדים()
On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות
Dim doc As Document
Dim rng As Range
Dim i As Integer
Dim word As Range' קבלת המסמך הפעיל Set doc = ActiveDocument ' מעבר על כל המילים במסמך For Each rng In doc.StoryRanges Do For Each word In rng.Words ' אם הצבע אדום בהיר או ירוק בהיר, נסיר אותו If word.font.Color = RGB(1, 255, 1) Or word.font.Color = RGB(255, 1, 1) Then word.font.Color = wdColorAutomatic End If Next word Set rng = rng.NextStoryRange Loop While Not rng Is Nothing Next rngאני התכוונתי לזה:
Sub FindGreenAndRedText() ' חיפוש טקסט בצבע ירוק With Selection.Find .ClearFormatting .Font.Color = RGB(1, 255, 1) .Text = "" .Replacement.Text = "" .Wrap = wdFindContinue .Format = True .Execute Replace:=wdReplaceNone End With ' חיפוש טקסט בצבע אדום With Selection.Find .ClearFormatting .Font.Color = RGB(255, 1, 1) .Text = "" .Replacement.Text = "" .Wrap = wdFindContinue .Format = True .Execute Replace:=wdReplaceNone End With End Sub -
איך עושים בחיפוש והחלפה, תיקון לשגיאות הבאות:
,א = אם יש פסיק ואז אות, שירד הפסיק לפני האות ויהיה אחריה.
שלום(וברכה) = אם התו הפותח של סוגריים, צמוד למילה הקודמת - איך מכניסים ריווח לפני הסוגריים [החלף: "^$(" ב: "^& (" גורם שהתוצאה תהיה כך: "( (" ]
שלום.(וברכה) = אם התו הפותח של סוגריים, צמוד לנקודה או פסיק - איך מכניסים ריווח לפני הסוגריים.
שלום)וברכה = אם התו הסוגר של סוגריים, צמוד למילה הבאה - איך מכניסין ריווח אחרי הסוגריים. -
עשיתי מאקרו תיקון שגיאות (ראה לעיל https://mitmachim.top/topic/51883/שיתוף-מתעדכן-אוסף-מאקרו-לוורד-אינדקס-מאקרו-שימושי-הוראות-חשובות/208?_=1737235546512)
- איך עושים שבסוף התיקון יפתח לי חלון ובו יופיע כמה תיקונים נעשו במסמך, ואיזה תיקונים?
הצלחתי להגיע למצב הזה-
(העתקתי את הפקודה הזו מהאמקרו של "קיצורי מקשים מותאמים אישית")
אבל איך אני גורם לו לכתוב אלו תיקונים נעשו.
-
נ.ב. האם ישנה אפשרות לבטל\לאפשר חלונית זו לפי בחירה, או רק ע"י מחיקת הפקודה הזו מתוך המאקרו?
-
נ.ב.ב איך אני גורם להודעה להופיע למספר שניות ולאחמ"כ להיעלם בלי שאצטרך ללחוץ על אישור?
תודה רבה!
- איך עושים שבסוף התיקון יפתח לי חלון ובו יופיע כמה תיקונים נעשו במסמך, ואיזה תיקונים?
-
י יאיר דניאל התייחס לנושא זה
-
עשיתי מאקרו תיקון שגיאות (ראה לעיל https://mitmachim.top/topic/51883/שיתוף-מתעדכן-אוסף-מאקרו-לוורד-אינדקס-מאקרו-שימושי-הוראות-חשובות/208?_=1737235546512)
- איך עושים שבסוף התיקון יפתח לי חלון ובו יופיע כמה תיקונים נעשו במסמך, ואיזה תיקונים?
הצלחתי להגיע למצב הזה-
(העתקתי את הפקודה הזו מהאמקרו של "קיצורי מקשים מותאמים אישית")
אבל איך אני גורם לו לכתוב אלו תיקונים נעשו.
-
נ.ב. האם ישנה אפשרות לבטל\לאפשר חלונית זו לפי בחירה, או רק ע"י מחיקת הפקודה הזו מתוך המאקרו?
-
נ.ב.ב איך אני גורם להודעה להופיע למספר שניות ולאחמ"כ להיעלם בלי שאצטרך ללחוץ על אישור?
תודה רבה!
@יאיר-דניאל כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
נ.ב.ב איך אני גורם להודעה להופיע למספר שניות ולאחמ"כ להיעלם בלי שאצטרך ללחוץ על אישור?
תודה רבה!אתה יכול לייצר userform ולהשתמש בו בצורה של modless
https://bettersolutions.com/vba/userforms/modeless.htmמחפש מדריך ארוך יותר על הנושא של userform עיין כאן:
https://excelmacromastery.com/vba-userform/comment-page-1/ - איך עושים שבסוף התיקון יפתח לי חלון ובו יופיע כמה תיקונים נעשו במסמך, ואיזה תיקונים?
-
עשיתי מאקרו תיקון שגיאות (ראה לעיל https://mitmachim.top/topic/51883/שיתוף-מתעדכן-אוסף-מאקרו-לוורד-אינדקס-מאקרו-שימושי-הוראות-חשובות/208?_=1737235546512)
- איך עושים שבסוף התיקון יפתח לי חלון ובו יופיע כמה תיקונים נעשו במסמך, ואיזה תיקונים?
הצלחתי להגיע למצב הזה-
(העתקתי את הפקודה הזו מהאמקרו של "קיצורי מקשים מותאמים אישית")
אבל איך אני גורם לו לכתוב אלו תיקונים נעשו.
-
נ.ב. האם ישנה אפשרות לבטל\לאפשר חלונית זו לפי בחירה, או רק ע"י מחיקת הפקודה הזו מתוך המאקרו?
-
נ.ב.ב איך אני גורם להודעה להופיע למספר שניות ולאחמ"כ להיעלם בלי שאצטרך ללחוץ על אישור?
תודה רבה!
@יאיר-דניאל כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
איך עושים שבסוף התיקון יפתח לי חלון ובו יופיע כמה תיקונים נעשו במסמך, ואיזה תיקונים?
עיין כאן
https://stackoverflow.com/a/52868742העיקרון הוא להשתמש עם לולאת חיפוש אבל יש לזה מחיר באיטיות
- איך עושים שבסוף התיקון יפתח לי חלון ובו יופיע כמה תיקונים נעשו במסמך, ואיזה תיקונים?
-
@יאיר-דניאל כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
איך עושים שבסוף התיקון יפתח לי חלון ובו יופיע כמה תיקונים נעשו במסמך, ואיזה תיקונים?
עיין כאן
https://stackoverflow.com/a/52868742העיקרון הוא להשתמש עם לולאת חיפוש אבל יש לזה מחיר באיטיות
@pcinfogmach תודה, אבל האמת לא התקדמתי כלום...
הכל שם באנגלית והתרגום של גוגל לא מספק, כך שלא הצלחתי להסתדר.
אשמח אם יש למישהו הדרכה בעברית- או אם יש מישהו שיוכל לכתוב לי את הפקודה למאקרו,, ולעלות את זה כאן.
-
@pcinfogmach תודה, אבל האמת לא התקדמתי כלום...
הכל שם באנגלית והתרגום של גוגל לא מספק, כך שלא הצלחתי להסתדר.
אשמח אם יש למישהו הדרכה בעברית- או אם יש מישהו שיוכל לכתוב לי את הפקודה למאקרו,, ולעלות את זה כאן.
@יאיר-דניאל הקוד שנמצא שם הוא כדי לתת מידע על הקוד
שלמעלה שלמעשה לא מחליף שום דבר - הוא פשוט סופר את המקרים של מה שנמצא. -
@יאיר-דניאל הקוד שנמצא שם הוא כדי לתת מידע על הקוד
שלמעלה שלמעשה לא מחליף שום דבר - הוא פשוט סופר את המקרים של מה שנמצא.@u88 ===group
זה מה שהיה שםSub Demo() Application.ScreenUpdating = False Dim i As Long With ActiveDocument.Range With .Find .ClearFormatting .Replacement.ClearFormatting .Text = InputBox("What is the Text to Find") .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute End With Do While .Find.Found i = i + 1 .Collapse wdCollapseEnd .Find.Execute Loop End With Application.ScreenUpdating = True MsgBox i & " instances found." End Sub -
@יאיר-דניאל הקוד שנמצא שם הוא כדי לתת מידע על הקוד
שלמעלה שלמעשה לא מחליף שום דבר - הוא פשוט סופר את המקרים של מה שנמצא.@u88 אני יודע, וזה בדיוק מה שאני שואל, איך אני מזין לו שיבדוק ויציג לי את כל התיקונים שנעשו ע"י המאקרו שלי
-
@u88 ===group
זה מה שהיה שםSub Demo() Application.ScreenUpdating = False Dim i As Long With ActiveDocument.Range With .Find .ClearFormatting .Replacement.ClearFormatting .Text = InputBox("What is the Text to Find") .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute End With Do While .Find.Found i = i + 1 .Collapse wdCollapseEnd .Find.Execute Loop End With Application.ScreenUpdating = True MsgBox i & " instances found." End Sub@u88 כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
זה מה שהיה שם
איפה זה שם?
-
@u88 כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:
זה מה שהיה שם
איפה זה שם?
@יאיר-דניאל באתר ש@pcinfogmach הביא לך
-
@יאיר-דניאל באתר ש@pcinfogmach הביא לך
@u88 לא הבנתי מה אתה רוצה.
בכ"א אני צריך משהו ספציפי, ואשמח אם מישהו יוכל לעזור לי:
איך אני כותב פקודת מאקרו שתציג לי (בהודעה, כך:
את כל השינויים שנעשו במסמך - ע"י המאקרו של תיקון שגיאות שהעלתי למעלה.
אולי @pcinfogmach יוכל לעזור? -
@u88 לא הבנתי מה אתה רוצה.
בכ"א אני צריך משהו ספציפי, ואשמח אם מישהו יוכל לעזור לי:
איך אני כותב פקודת מאקרו שתציג לי (בהודעה, כך:
את כל השינויים שנעשו במסמך - ע"י המאקרו של תיקון שגיאות שהעלתי למעלה.
אולי @pcinfogmach יוכל לעזור?@יאיר-דניאל
אתה מתכוויןלשאול איך כותבים את המאקרו? או שאתה מתכווין לבקש שמישהו יעשה לך את העבודה ויכתוב לך את המאקרו?
 { const baseUrl = "https://www.google.co.il/search?q=site:mitmachim.top"; const m = location.pathname.match(/^\/(topic|category)\/(\d+)/); const type = m ? m[1] : null; const id = m ? m[2] : null; let searchInput; function search(path = "") { const query = searchInput.value.trim(); if (query) { window.open(`${baseUrl}${path}%20${encodeURIComponent(query)}`, "_blank"); } } let buttons = {}; buttons.searchAll = { id: "bb-search-all", label: `חיפוש ${type ? "בכל הפורום" : ""}`, className: type ? "btn-secondary" : "btn-primary", callback: () => search(), }; if (type === "topic") { buttons.searchTopic = { label: "חיפוש בנושא זה", className: "btn-primary", callback: () => search(`/topic/${id}`), }; } else if (type === "category") { buttons.searchCategory = { label: "חיפוש בקטגוריה זו", className: "btn-primary", callback: () => search(`/category/${id}`), }; } buttons.cancel = { label: "ביטול", className: "btn-default", "data-bs-dismiss": "modal" }; const dialog = bootbox.dialog({ title: '<div style="text-align:center;"><img src="/assets/uploads/files/1625950269825-mt-google.png" width="400" alt="חיפוש בגוגל"></div>', message: '<input id="bb-inp" class="bootbox-input bootbox-input-text form-control" placeholder="הקלידו כדי לחפש בגוגל" autocomplete="off"/>', buttons, backdrop: true, show: true, onEscape: true }); dialog.on("shown.bs.modal", function () { searchInput = document.getElementById("bb-inp"); if (searchInput) { searchInput.focus(); searchInput.addEventListener("keydown", function (e) { if (e.key === "Enter") { e.preventDefault(); const query = this.value.trim(); if (query) { search(); dialog.modal("hide"); } } else if (e.key === "Escape") { e.preventDefault(); dialog.modal("hide"); } }); } const searchAllButton = document.getElementById("bb-search-all"); if (searchAllButton) { searchAllButton.title = "לחצו על אנטר כדי לחפש"; } }); })(); void 0;){kind=link}