Hirdetés
- GoodSpeed: Munkaügyi helyzet Hajdú-Biharban: észak és dél
- Sub-ZeRo: Euro Truck Simulator 2 & American Truck Simulator 1 (esetleg 2 majd, ha lesz) :)
- Luck Dragon: Asszociációs játék. :)
- droidic: Safe Mode az agyban
- sziku69: Fűzzük össze a szavakat :)
- Yézi: "Új" gépház
- Gurulunk, WAZE?!
- GoodSpeed: 3I/Atlas: Üstökös vagy idegen civilizáció űrhajója?
- ubyegon2: Airfryer XL XXL forrólevegős sütő gyakorlati tanácsok, ötletek, receptek
- urandom0: Száműztem az AI-t az életemből
Új hozzászólás Aktív témák
-
válasz
aleister
#1019
üzenetére
Hali!
Szivesen!
Annyit még azért hozzátennék(elfelejtettem írni), hogy azért van egy kis "hibája" a proginak.
Ha egy oldal végén nem oldaltörés van, hanem csak úgy átcsúszik a következő oldalra, akkor egy plusz üres lapot berak pluszba a mentett fájlba...
De ez csak egy kis szépséghiba... könnyen orvosolható
Fire.
-
válasz
aleister
#1015
üzenetére
Hali!
Neked nem kell semmi VBA programozás tudás hozzá. Lépésenként:
1. Nyisd meg a dokumentumot, amit fel akarsz darabolni(csak azt!!!)
2. Üsd le az ALT+F11 billentyű kombinációt, ezzel belépsz a VBA-ba
3. Hozz létre egy modult, ahogy az alábbi képen látszik
4. másold ki a forráskódot(lejebb találod majd) és illeszd be ide és futtasd, ahogy az alábbi képen látszik

5. ha befejezte a munkát(eltart egy ideig, mert direkt úgy írtam, hogy lásd miközben dolgozik, ezért viszont lassabb) és becsukod a VBA editor illetve a wordot akkor NE MENTS SEMMILYEN MÓDOSÍTÁST, HA KÉRDEZI!!!
6. A makró létrehoz(abba a könyvtárba ahol az eredeti doksi volt) 1.doc, 2.doc, 3.doc...stb fájlokat. AZONBAN: Nem nézem azt, hogy létezik-e ilyen fájl már a könyvtárban, tehát erre figyelj, mert kérdés nélkül felülír minden azonos nevű fájlt!!!(1.doc, 2.doc...stb)
Itt a forrás:
Sub Fire_Document_Splitter()
Dim Pages
Dim MyRange As Range
Dim OriginalDoc As Document
Dim SpilittedDoc As Document
Set OriginalDoc = ActiveDocument
Set MyRange = OriginalDoc.Range
'Application.ScreenUpdating = False
Pages = OriginalDoc.Content.ComputeStatistics(wdStatisticPages)
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst
For i = 1 To Pages
If i = Pages Then
MyRange.End = ActiveDocument.Range.End
Else
Selection.GoTo wdGoToPage, wdGoToAbsolute, i + 1
MyRange.End = Selection.Start
End If
MyRange.Copy
Set SpilittedDoc = Documents.Add
SpilittedDoc.Range.Paste
SpilittedDoc.Range.Find.Execute Findtext:="^m", ReplaceWith:=""
SpilittedDoc.SaveAs FileName:=i & ".doc"
SpilittedDoc.Close
MyRange.Collapse wdCollapseEnd
Next i
Application.ScreenUpdating = True
Set OriginalDoc = Nothing
Set SpilittedDoc = Nothing
Set MyRange = Nothing
End SubFire.
-
Új hozzászólás Aktív témák
- Gamer PC-Számítógép! Csere-Beszámítás! I7 10700 / 32GB DDR4 / RX 6700XT 12GB / 512 SSD + 1TB HDD
- Ducky One 3 FULL/TKL/SF/MINI billentyűzetek többféle színben és kapcsolókkal!
- Dell Latitude Precision Üzleti gépek, 2-in-1 gépek, 3-13. gen.
- HIBÁTLAN iPhone 14 128GB Midnight -1 ÉV GARANCIA - Kártyafüggetlen, MS3240
- Creative Sound BlasterX G6 7.1 USB külső hangkártya
Állásajánlatok
Cég: Laptopszaki Kft.
Város: Budapest
Cég: BroadBit Hungary Kft.
Város: Budakeszi

