Hirdetés
- Asszociációs játék. :)
- Itt az új LOGOUT!
- Ingyen kellene, de tegnapra
- "A homoszexualitás természetellenes" 😠
- Vissza a jövőbe film Peabody fészere baki.
- VodkaTV kiegészítő Kodira
- Rap, Hip-hop 90'
- Euro Truck Simulator 2 & American Truck Simulator 1 (esetleg 2 majd, ha lesz) :)
- leslieke farmerzsebe
- Szólánc.
-
LOGOUT.hu
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
Delila_1
veterán
Az útvonalat, és a füzet nevét kell átírnod.
Sub Osszevon()
Const utvonal = "E:\Eadat\Excel fórumok\Próba\" 'Itt írd át az útvonalat
Dim FN As String, WB As Workbook, WBGy As Workbook
Dim lap As Integer, oszlop As Integer, oszlop_gy As Integer
oszlop_gy = 1
Set WBGy = Workbooks("Gyűjtő.xls") 'Itt írd át a gyűjtő füzeted nevét
ChDir utvonal
FN = Dir(utvonal & "*.xls", vbNormal)
Do
If FN <> "." And FN <> ".." Then
Workbooks.Open Filename:=FN
For lap = 1 To Worksheets.Count
Sheets(lap).Select
oszlop = Cells(1, Columns.Count).End(xlToLeft).Column
Columns(oszlop).Copy WBGy.Sheets(1).Cells(1, oszlop_gy)
oszlop_gy = oszlop_gy + 1
Next
ActiveWindow.Close
End If
FN = Dir()
Loop Until FN = ""
End SubProgramozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
veterán
Az lehet a baj, hogy a lapokon az első sorban nincs adat. Az
oszlop = Cells(1, Columns.Count).End(xlToLeft).Column
sorban a kiemelt 1-es adja, hogy az első sorba írt adatok alapján nézze meg a makró, melyik az utolsó oszlop. Ezt a számot írd át akkorára, ahol már biztosan van minden lapodon adat.
[ Szerkesztve ]
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
veterán
Sub Osszevon()
Const utvonal = "E:\Eadat\Excel fórumok\Próba\" 'Itt írd át az útvonalat
Dim FN As String, WB As Workbook, WBGy As Workbook
Dim lap As Integer, oszlop As Integer, oszlop_gy As Integer
oszlop_gy = 3
Set WBGy = Workbooks("Gyűjtő.xls") 'Itt írd át a gyűjtő füzeted nevét
ChDir utvonal
FN = Dir(utvonal & "*.xls", vbNormal)
Do
If FN <> "." And FN <> ".." Then
Workbooks.Open Filename:=FN
For lap = 1 To Worksheets.Count
Sheets(lap).Select
Range("H28:H80").Copy WBGy.Sheets(1).Cells(9, oszlop_gy)
oszlop_gy = oszlop_gy + 1
Next
ActiveWindow.Close
End If
FN = Dir()
Loop Until FN = ""
End SubProgramozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
veterán
Jó, hogy így apránként csepegteted az óhajokat, nem hagysz ellustulni.
Az új kívánságaid alkalmával mindig létre kell hoznom 3 füzetet, különböző lapszámmal, és különböző adatokkal a makró próbájához.Sub Osszevon_()
Const utvonal = "E:\Eadat\Excel fórumok\Próba\"
Dim FN As String, WB As Workbook, WBGy As Workbook
Dim lap As Integer, oszlop As Integer, oszlop_gy As Integer
Application.ScreenUpdating = False
oszlop_gy = 3
Set WBGy = Workbooks("Gyűjtő_FrostyBoy84.xls")
ChDir utvonal
FN = Dir(utvonal & "*.xls", vbNormal)
Do
If FN <> "." And FN <> ".." Then
Workbooks.Open Filename:=FN
For lap = 1 To Worksheets.Count
Sheets(lap).Select
Range("H28:H80").Copy
ActiveWindow.ActivatePrevious
Cells(9, oszlop_gy).Select
Selection.PasteSpecial Paste:=xlPasteValues
ActiveWindow.ActivateNext
oszlop_gy = oszlop_gy + 1
Next
ActiveWindow.Close
End If
FN = Dir()
Loop Until FN = ""
Application.ScreenUpdating = True
End SubBugizozi
Lehet, hogy a képletek külső hivatkozásokat tartalmaznak, új füzetbe való másoláskor felborulnak.Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Delila_1
veterán
Nem a sok kérdéssel van baj, hanem azzal, hogy nem gondoltad át a kérdés feltevése előtt, mit is szeretnél elérni.
Először a lapok teljes utolsó oszlopának a másolását kérted, utána egy-egy meghatározott tartományét más helyre, végül azt, hogy ezek értékét vigyük be az új füzetbe. Az utolsó verziót már az első alkalommal is tudhattad.
Nyugodtan tedd fel a más témára vonatkozó további kérdéseidet.
Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.
-
Mutt
senior tag
Hali,
Plusz tartományt kellene másolni (E9:E26) ami a 9-14 sorba illesztené be és utána jönne a fent látható tartomány de a 15. sortól illesztené be. Egy kijelöléssel és egy másolással nemigen lehetséges.
Az E9:E26-os tartomány 17 soros, nem fog beleférni a 9-14 sorok közé!
A kódod magját kell duplikálnod az új tartomány másolásához.
For lap = 1 To Worksheets.Count
'az újabb tartomány másolása
Sheets(lap).Range("E9:E26").Copy
ActiveWindow.ActivatePrevious
Cells(9, oszlop_gy).Select
Selection.PasteSpecial Paste:=xlPasteValues
ActiveWindow.ActivateNext
'a régi tartomány másolása a 15. sorba
Sheets(lap).Range("G5:G197").Copy
ActiveWindow.ActivatePrevious
Cells(15, oszlop_gy).Select
Selection.PasteSpecial Paste:=xlPasteValues
ActiveWindow.ActivateNext
oszlop_gy = oszlop_gy + 1
Nextüdv
A tanácsaimat ingyen adom. Ha nem tetszik, akkor kérlek ne kritizáld! / https://github.com/viszi/codes/tree/master/Excel
Új hozzászólás Aktív témák
Hirdetés
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - 2990 Ft-tól!
- 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!
- Microsoft licencek KIVÉTELES ÁRON AZONNAL - UTALÁSSAL IS AUTOMATIKUS KÉZBESÍTÉS - Windows és Office
- Adobe Előfizetések - Adobe Creative Cloud All Apps - 12 Hónap - NYÁRI AKCIÓ!
Állásajánlatok
Cég: Ozeki Kft
Város: Debrecen
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest