ברצוני להודות לישראל על המסירות וההשקעה, עד להצלחה המלאה - מאקרו שמפצל מסמך המחולק לפרקים - למסמכים מרובים ושומר אותם.
יישר כח!
אצרף כאן את המאקרו המתוקן והמלא.
כשהמאקרו מבקש לבחור תיקיה - יש להזין את תיקיית היעד בה יווצרו המסמכים המפוצלים. אין צורך להזין את היעד של המקור, יש לפתוח את הקובץ המיועד לפיצול, ועליו להפעיל את המאקרו.
[המאקרו כאן מבוסס על כך שהמסמך מחולק לפרקים - כדוגמת "משלי פרק א" והוא חותך אותו עד "משלי פרק ב" וחוזר חלילה עד שמסיים את כל המסמך. עוד מבוסס המאקרו על כך שהכותרת הנ"ל היא בולד, עם קו תחתון].
Sub פיצולמסמך()
Dim strFolder As String, wdDoc As Document, MyRange As Range, MyStop As Integer
Application.ScreenUpdating = False
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Selection.HomeKey wdStory
start:
If MyStop = 1 Then Exit Sub
With Selection.Find
.ClearFormatting
.Font.BoldBi = True
.Font.Underline = wdUnderlineSingle
.Execute findText:="משלי פרק", MatchWildcards:=True, Format:=True, Wrap:=wdFindContinue
If .Found = True Then
Set MyRange = Selection.Range
.Font.BoldBi = True
.Font.Underline = wdUnderlineSingle
.Execute findText:="משלי פרק", MatchWildcards:=True, Format:=True, Wrap:=wdFindStop
If .Found Then
MyRange.End = Selection.start
Else
MyRange.End = ActiveDocument.Range.End
MyStop = 1
End If
Selection.HomeKey
MyRange.Copy
'Set Copyng = MyRange
Set wdDoc = Documents.Add(DocumentType:=wdNewBlankDocument)
wdDoc.Range.PasteAndFormat (wdFormatOriginalFormatting)
'wdDoc.Range.text = Copyng.text
ChangeFileOpenDirectory strFolder
wdDoc.SaveAs FileName:=Left(MyRange.Text, MyRange.Paragraphs(1).Range.Characters.Count - 1) & ".docx", _
FileFormat:=wdFormatXMLDocument
wdDoc.Close
GoTo start
End If
End With
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "בחר תיקייה", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
הנושאים החמים
הנושאים החמים
