- Samsung Galaxy S24 - nos, Exynos
- Jelentősen drágulhatnak a Samsung hajlíthatók
- Xiaomi 14 Ultra - Leica hercegnő
- Mobilinternet EU-n kívül, eSIM adatcsomagok használata
- Milyen okostelefont vegyek?
- iPhone topik
- Samsung Galaxy Watch5 Pro - kerek, de nem tekerek
- Közel két napos üzemidőt ígér a Realme Buds Air 5 Pro
- Egy kabaré volt az Edge 50 család belgrádi bemutatója
- Honor 200 Pro - mobilportré
Hirdetés
-
Lőn világosság: megérkezett új fénymérőnk
ma A márka és a metódus maradt, gyorsan pótoltuk a Honor 200 Pro méréseit.
-
Steamre tart a Prince of Persia: The Lost Crown
gp Hamarosan a Valve áruházában is elérhetővé válik a játék teljes kiadása.
-
Retro Kocka Kuckó 2024
lo Megint eltelt egy esztendő, ezért mögyünk retrokockulni Vásárhelyre! Gyere velünk gyereknapon!
-
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
-
Delila_1
Topikgazda
válasz jaszy83 #13345 üzenetére
Akkor egyszerűsítsünk!
A makró a Felvitel lapról veszi az adatokat, és a Munka3 lapra másolja át. Az új tartományt rendezi, majd egyesíti az A oszlop egyesíthető celláit, végül megadja a keretet.
Mindezek előtt a Munka3 lapot kitakarítja a címsor kivételével.Nem tudom, mennyi adatod lesz, a takarítást az A2:K5000 tartományban végeztetem el. Azokat a sorokat, ahol a lapok nevén, vagy a tartományon módosítani kell, csillagokkal kommenteztem.
Sub Rendez()
Dim sor As Long, usor As Long, WS As Worksheet, WSF As Worksheet
Set WS = Sheets("Munka3") '***************
Set WSF = Sheets("Felvitel") '***************
usor = WSF.Range("A" & Rows.Count).End(xlUp).Row
WS.Select
'Előző cella-egyesítések megszüntetése
Columns(1).MergeCells = False
'Előző adatok törlése
Rows("2:5000").Delete '***************
'Adatok a Felvitel lapról a Munka3-ra
For sor = 2 To usor
Cells(sor, 1) = WSF.Cells(sor, 1)
Cells(sor, 2) = WSF.Cells(sor, 2)
Cells(sor, 3) = WSF.Cells(sor, 3)
Next
'Rendezés
Columns("A:K").Select '***************
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("A2:A" & usor) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveSheet.Sort.SortFields.Add Key:=Range("C2:C" & usor) _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A1:C" & usor)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Cellaegyesítés az A oszlopban
For sor = usor To 2 Step -1
If Cells(sor, 1) = Cells(sor - 1, 1) Then
Cells(sor - 1, 1) = ""
Range(Cells(sor - 1, 1), Cells(sor, 1)).MergeCells = True
End If
Next
'Keret
Range("A1:K" & usor).Select '***************
Selection.Borders(xlEdgeLeft).LineStyle = xlThin
Selection.Borders(xlEdgeTop).Weight = xlThin
Selection.Borders(xlEdgeBottom).Weight = xlThin
Selection.Borders(xlEdgeRight).Weight = xlThin
Selection.Borders(xlInsideVertical).Weight = xlThin
Selection.Borders(xlInsideHorizontal).Weight = xlThin
End Sub[ 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.
Új hozzászólás Aktív témák
- Bitdefender Total Security 3év/3eszköz! - "Tökéletes védelem most kedvező áron..."
- Autómatricák a legjobb minőségben, több ezer minta! PH tagoknak 30% kedvezmény!
- Game Pass Ultimate előfizetések 1 - 25 hónapig azonnali kézbesítéssel a LEGOLCSÓBBAN!
- Megmaradt - Eredeti Humble, Choice - Steam kulcsok
- PC JÁTÉKOK (OLCSÓ STEAM, EA , UPLAY KULCSOK ÉS SOKMINDEN MÁS IS 100% GARANCIA )