- Android alkalmazások - szoftver kibeszélő topik
- Profi EKG-s óra lett a Watch Fitből
- Honor 400 Pro - gép a képben
- Samsung Galaxy S21 és S21+ - húszra akartak lapot húzni
- Honor Magic7 Pro - kifinomult, költséges képalkotás
- Samsung Galaxy A54 - türelemjáték
- Milyen okostelefont vegyek?
- Telekom mobilszolgáltatások
- Apple iPhone 16 Pro - rutinvizsga
- India felől közelít egy 7550 mAh-s Redmi
-
Mobilarena
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
-
#8746
Fire/SOUL/CD
félisten
iwu
#8745
-
#8671
m.zmrzlina
senior tag
iwu
#8670
m.zmrzlina
senior tag
Az én megoldásomban a
Columns("A:B").EntireColumn.AutoFit
helyett ezt:
With Columns("A:B")
.Select
.EntireColumn.AutoFit
.HorizontalAlignment = xlLeft
End Withbetenni.
Ja és a
activerow = Range("A" & sorsz + 1, "I" & sorsz + 1).Value
sort törölni. Nem létező változónak ad értéket majd nem használja semmire.
Mire észrevettem, hogy benne maradt már nem volt szerkeszthető a hsz. -
#8668
m.zmrzlina
senior tag
iwu
#8661
m.zmrzlina
senior tag
Nekem ezt sikerült kiötleni:
Sub valogat()
Dim sorsz As Integer
Dim holavege As Integer
Sheets("Munka1").Select
Cells(Rows.Count, 1).End(xlUp).Select
holavege = ActiveCell.Row
For sorsz = 1 To holavege - 1
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(sorsz + 1).Name = Sheets(1).Cells(sorsz + 1, 1).Value
Sheets("Munka1").Select
Range("A1:I1").Select
Selection.Copy
Sheets(1 + sorsz).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Munka1").Select
Range("A" & sorsz + 1, "I" & sorsz + 1).Select
activerow = Range("A" & sorsz + 1, "I" & sorsz + 1).Value
Selection.Copy
Sheets(1 + sorsz).Select
Cells(1, 2).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Columns("A:B").EntireColumn.AutoFit
Next sorsz
Sheets("Munka1").Delete
ActiveWorkbook.SaveAs "C:\Documents and Settings\agb\Dokumentumok\masneven.xlsm"
End SubAbból a munkafüzetből indul ahol a kiindulási lista van, elkészíti a munkalapokat igény szerint, majd törli az eredeti lista munkalapját és menti a munkafüzetet más néven.
Nem egy minden részletében kimunkált végleges megoldás inkább csak gondolatébresztő, de működik.Érdekelnének a szakértő vélemények.
-
Delila_1
veterán
Régen leveleztünk, biztos a régi címemmel próbálkoztál. Inkább beírom ide a kódot. A füzetet, amiben most 1 lapon vannak az adatok, Eredeti.xls-nek neveztem el, az újat, amit a makró hoz létre, UjFuzet.xls névvel illettem.
Az útvonalat az első sorban írd át.Sub SokLap()
Const utvonal As String = "F:\Eadat\"
Dim lapsz As Integer, lap As Integer
Dim lapnev As String
lapsz = Range("A" & Rows.Count).End(xlUp).Row
Application.SheetsInNewWorkbook = lapsz - 1
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=utvonal & "UjFuzet.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Windows("Eredeti.xls").Activate
For lap = 2 To lapsz
lapnev = Cells(lap, 1)
Workbooks("UjFuzet.xls").Sheets(lap - 1).Name = lapnev
Rows(1).EntireRow.Copy Workbooks("UjFuzet.xls").Sheets(lapnev).Rows(1)
Rows(lap).EntireRow.Copy Workbooks("UjFuzet.xls").Sheets(lapnev).Rows(2)
Next
Windows("UjFuzet.xls").Activate
For lap = 1 To lapsz - 1
Sheets(lap).Select
Range("A1:I2").Copy
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Next
Application.SheetsInNewWorkbook = 3
End Sub -
-
-
Delila_1
veterán
Jelöld ki a táblát, vagy annak azt a részét, ahol be akarod tömni a lyukakat.
Szerkesztés/Ugrás/Irányított ugrás/Üres cellák
Beírod-> =
nyomsz egy fel nyilat
Ctrl+Enter
Ez egyszerre az összes kijelölt celládba beviszi a fölötte lévő adatot hivatkozással. Ha fixen akarod (nem képlettel) látni ezután a most bevitt értékeket, ezután kijelölöd újra az összes adatot, Ctrl+C, Irányított beillesztés/Értéket. -
#2888
DoubleLayer
csendes tag
iwu
#2887
DoubleLayer
csendes tag
Lehet, hogy nem volt egyértelmű az első leírásom, bocs.
Tehát egy cellában a teljes cím szerepel, mittudomén mondjuk: "1111 Budapest, Váci út 25." - a példáknál maradva, ez lenne a D12 cella.
Lehet, hogy ki kell vennem előre, külön cellába az irányítószámokat... Csak az megint egy csomó plusz munka lenne visszafelé... -
-
Gh0sT
addikt
Darabtelivel nemtom megcsinálni.
De itt egy másik módszer:
Az oszlopod mellé beszúrsz egy másik oszlopot a következő képlettel:
=HA(A1>10;HA(A1<20;1;0);0)
Ez 1 értéket ad, ha teljesül a feltétel, 0-t, ha nem. Aztán kell valahova egy szumma, és már meg is vagy. A képletet tartalmazó oszlopot pedig elrejted, hogy szép legyen.
Szerk.: de szar, nemtok semmi elegáns megoldást, de még próbálkozom.
[Szerkesztve]
VBScript?
Új hozzászólás Aktív témák
Hirdetés
Fferi50- Magga: PLEX: multimédia az egész lakásban
- iPhone-t használók OFF topikja
- Luck Dragon: Asszociációs játék. :)
- Milyen videókártyát?
- Melyik tápegységet vegyem?
- Elektromos rásegítésű kerékpárok
- Milyen asztali (teljes vagy fél-) gépet vegyek?
- Milyen légkondit a lakásba?
- sziku69: Szólánc.
- sziku69: Fűzzük össze a szavakat :)
- További aktív témák...
- Vírusirtó, Antivirus, VPN kulcsok
- Assassin's Creed Shadows Collector's Edition PC
- Microsoft licencek KIVÉTELES ÁRON AZONNAL - UTALÁSSAL IS AUTOMATIKUS KÉZBESÍTÉS - Windows és Office
- Eladó Steam kulcsok kedvező áron!
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- AKCIÓ! ASROCK H310CM i5 9600K 32GB DDR4 500GB SSD RTX 3050 8GB DeepCool Tesseract SW 500W
- Azonnali kézbesítés az év bármely pillanatában
- Eladó ÚJ, BONTATLAN Samsung Galaxy A05s 4/64GB ezüst / 12 hónap jótállással!
- BESZÁMÍTÁS! Gigabyte B760M i7 12700K 16GB DDR4 512GB SSD RX 6700 XT 12GB Rampage SHIVA Enermax 750W
- Csere-Beszámítás!AMD Asztali számítógép PC Játékra! R5 5600/ RX 6700XT 12GB / 16GB DDR4 / 500GB SSD
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: PC Trade Systems Kft.
Város: Szeged