Ú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átszik4. 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
- Adobe Előfizetések - Adobe Creative Cloud All Apps - 12 Hónap - NYÁRI AKCIÓ!
- Sea of Thieves Premium Edition és Egyéb Játékkulcsok.
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Fujitsu USB Port Replicator PR09 docking station (1x5K vagy 2x4K felbontás) (DisplayLink)
- BESZÁMÍTÁS! 1TB Corsair MP700 NVMe SSD meghajtó garanciával hibátlan működéssel
- Csere-Beszámítás! Asztali számítógép PC Játékra! I5 12400F / RTX 3070 / 32GB DDR4 / 500GB SSD
- Dell latitude, precision, xps, magyar világítós billentyűzetek eladóak
- ÁRGARANCIA! Épített KomPhone Ryzen 5 5600X 16/32/64GB RAM RTX 5060 8GB GAMER PC termékbeszámítással
Állásajánlatok
Cég: CAMERA-PRO Hungary Kft
Város: Budapest
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest