-
Fototrend
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
Ez a makró megcsinálja. Előbb új lapokra másolja az egyes sorokat, mindegyiket olyan nevű lapra, amilyen adatot tartalmaz az adott sor első (A) cellája.
Ezután az egyes lapokat áthelyezi 1-1 új fájlba, aminek a neve a lapnév + "_adott adat".Az utvonal = "E:\Eadat\" sorban írd át az útvonalat a sajátodra, a végén is legyen \ jel, mint itt.
A nev$ = utvonal & Sheets(1).Name & "_adott adat.xls" sor végén az .xls helyett írj .xlsx-et, ha 2003-asnál magasabb verziót alkalmazol.Címsort feltételezek, ezért az első ciklust (sorok másolása másik lapokra) a 2. sortól kezdtem a For sor% = 2 To usor% sorban. Címsor nélkül legyen ez a sor For sor% = 1 To usor%.
Sub Ujak()
Dim sor%, usor%, usor_1%, nev$, WS1 As Worksheet
Dim utvonal$, lap%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
utvonal = "E:\Eadat\" 'Itt írd be a saját útvonaladat ehelyett
usor% = Cells(Rows.Count, "A").End(xlUp).Row
Set WS1 = Sheets("Kezdőlap")
For sor% = 2 To usor%
nev$ = WS1.Cells(sor%, "A")
On Error GoTo Uj_lap
usor_1% = Sheets(nev$).Cells(Rows.Count, "A").End(xlUp).Row + 1
WS1.Rows(sor%).Copy Sheets(nev$).Cells(usor_1%, "A")
Next
For lap% = 1 To Sheets.Count - 1
nev$ = utvonal & Sheets(1).Name & "_adott adat.xls"
Sheets(1).Move
ActiveWorkbook.SaveAs Filename:=nev$, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Kész"
Exit Sub
Uj_lap:
If Err = 9 Then
Worksheets.Add.Name = nev$
Resume 0
Else
Error Err
End If
End Sub -
Delila_1
veterán
válasz
ThaBoss
#13577
üzenetére
Ha milliós sorszámod van, módosítani kell a makrón. A % jelet vedd le a változók végéről, és a Dim kezdetű sorokban így add meg: Dim sor As Double.
A % jellel a végén azonos a Dim sor As Integer-rel, de ez csak -32.768 és 32.767 közötti értékekre jó, ezen a tartományon kívül hibára futna.
-
Delila_1
veterán
válasz
ThaBoss
#13565
üzenetére
Itt az inverze.
Sub Valami_3()
Dim sor%, sor1%, ucso%, WS1 As Worksheet, WS2 As Worksheet
Dim kezd, vég
Set WS1 = Sheets(1)
Set WS2 = Sheets(2)
sor1% = 1
ucso% = WS1.Cells(Rows.Count, "A").End(xlUp).Row
For sor% = 2 To ucso%
kezd = WS1.Cells(sor%, "A")
vég = WS1.Cells(sor%, "B")
Do
sor1% = sor1% + 1
If WS1.Cells(sor%, "B") > WS1.Cells(sor%, "A") Then
WS2.Cells(sor1%, "A") = kezd
WS2.Cells(sor1%, "B") = kezd
WS2.Cells(sor1%, "C") = WS1.Cells(sor%, "C")
WS2.Cells(sor1%, "D") = WS1.Cells(sor%, "D")
kezd = kezd + 1
End If
Loop While vég >= kezd
Next
End Sub -
#13566
Delila_1
veterán
m.zmrzlina
#13563
Delila_1
veterán
válasz
m.zmrzlina
#13563
üzenetére
Az adat_3:adat_7, és az adat_10:adat_15-öt (esetleg az adat_18:adat_19-et is) ciklusban íratnám be. Akkor csak az adat_1 és adat_2 van szólóban.
sor = 1
For oszlop = 4 To 8
Cells(oszlop + 13, 3) = Cells(sor, oszlop)
NextFejreálltam a próbánál. Indítottam, és nem csinált semmit. Aztán rájöttem, hogy a belinkelt képedet néztem, az nem változott.
-
#13561
Delila_1
veterán
m.zmrzlina
#13559
Delila_1
veterán
válasz
m.zmrzlina
#13559
üzenetére
Nem látom a rendszert, pedig a programok erre épülnek.
-
-
Delila_1
veterán
válasz
ThaBoss
#13556
üzenetére
Óhajod parancs.
Sub Valami_1()
Dim sor%, sor1%, WS1 As Worksheet, WS2 As Worksheet
Dim info, képlet, usor, kezd
Set WS1 = Sheets(1): Set WS2 = Sheets(2)
sor% = 2: sor1% = 2
usor = WS1.Cells(sor%, "A").SpecialCells(xlLastCell).Row
info = WS1.Cells(sor%, "C"): képlet = WS1.Cells(sor%, "D")
kezd = WS1.Cells(sor%, "A")
For sor% = 2 To usor
If WS1.Cells(sor% + 1, "D") <> képlet Then
WS2.Cells(sor1%, "A") = kezd
WS2.Cells(sor1%, "B") = WS1.Cells(sor%, "B")
WS2.Cells(sor1%, "C") = WS1.Cells(sor%, "C")
WS2.Cells(sor1%, "D") = WS1.Cells(sor%, "D")
sor1% = sor1% + 1
kezd = WS1.Cells(sor% + 1, "A")
képlet = WS1.Cells(sor% + 1, "D")
End If
Next
End Sub -
Delila_1
veterán
válasz
motinka
#13549
üzenetére
Van 5 db számod: 1; 2; 3; 3; 3. A Nagy(tartomány;1) függvény megadja a legnagyobbat, ez a 3.
A Nagy(tartomány;2) a második legnagyobbat, 3-at ad.
A Nagy(tartomány;3) a harmadik legnagyobbat, szintén 3-at.
A Nagy(tartomány;4) eredménye 2, végül a Nagy(tartomány;5)-é 1.A C oszlopodban 171-szer szerepelt az iad hibakód. Az E oszlop darabteli függvénye pontosan ennyiszer hozza ki a 171-es eredményt. Ez azt jelenti, hogy a 171 után második legnagyobb számot, a 136-ot majd csak a Nagy(tartomány,172) függvény tudná produkálni.
-
#13546
Delila_1
veterán
Fire/SOUL/CD
#13545
Delila_1
veterán
válasz
Fire/SOUL/CD
#13545
üzenetére
Nézd meg a 13534-es hsz-t, abban van a füzet.
Ráérsz, csak este leszek újra monitor előtt.
-
Delila_1
veterán
válasz
motinka
#13537
üzenetére
Írtam a csatolt fájlban, hogy a nagy(E:E, 2), sőt a nagy(E:E, 171) is 171-et ad eredményül, mert az első 171 db szám mindegyike "legnagyobb". Leírtam, hogyan kerestem ki a szűrő segítségével az ez alatti legnagyobbat.
Meg lehetne oldani makróval, csak kissé lassú lenne a futása, és Neked nem lenne semmi dolgod.
-
Delila_1
veterán
válasz
motinka
#13525
üzenetére
Én sem értem teljesen, de úgy gondolom, hogy az "adott időszak" az adott hét lehet.
Heti bontásban készítettem egy táblázatot az egyes hibakódoknak megfelelő százalékos eloszlásról. Hogy ebből hogy lesz grafikon, azt még nem tudom, de a kérdés sem egészen fehér.
Az F oszlopba a C-ből speciális szűréssel (Adatok | Rendezés és szűrés | Speciális) írattam át az egyedi értékeket.
A G2 képlete:
=HAHIBA(DARABHATÖBB($A:$A;G$1;$C:$C;$F2)/DARABHATÖBB($C:$C;$F2);0)Ezt másolhatod jobbra, és le.
Ugyanígy készíthetsz összefoglaló táblázatot a Hibakód 2-ről. -
Delila_1
veterán
válasz
Z-Tom-ee
#13523
üzenetére
Írtam rá egy függvény Sarga_Osszeg néven.
Function Sarga_Osszeg(Tartomány As Range) As Double
Dim CV, ossz As Double
For Each CV In Tartomány
If CV.Interior.ColorIndex = 6 Then ossz = ossz + CV
Next
Sarga_Osszeg = ossz
End FunctionAz összegző cellába beírod: =sarga_osszeg(A1:G50), ahol az A1:G50 helyett a saját összegzendő tartományod kerül (egérrel is kijelölhető, mint minden más függvénynél). Adhatsz rövidebb nevet, két helyen kell átírnod a makróban.
Ezt a sárga hátteret veszi figyelembe, ennek a színkódja 6.
-
Delila_1
veterán
válasz
Lestat777
#13504
üzenetére
Feltettem ide a fájlt, ha már Fire megígérte, nem hazudtolom meg.
A dátumokat egyenként kell majd beírni, mert ha képlettel van (pl. C4-ben =A4+1), akkor nem találja meg.
A makró minden indításnál az előző napon be nem fejezett feladatokat átviszi a következő napra, az előző napiakból törli. Ha nem kell törölni, a makróban (ThisWorkbook-hoz rendelve) a megjegyzést tartalmazó sort töröld ki.
-
Delila_1
veterán
Fire még biztosan alszik a fél 1-es vacsorája után, ezért én válaszolok.
Az ÖSSZEFŰZ(">";D2) azonos értékű az ($E$2:E2;">" & D2)-vel. Az első megoldás is a D2 értékét fűzi hozzá a relációs jelhez.
Az =összefűz("alma";"fa") és az ="alma" & "fa" egyenlő eredményt ad.A -1-et nem értem, hiszen a feladatban az szerepelt, hogy a most érkező kocsival is kell számolni, elvégre az is várakozó helyre kerül.
-
Delila_1
veterán
válasz
Delila_1
#13499
üzenetére
Későn vettem észre, hogy ugyanannak a lapnak egy másik cellájára kell ugrani. Természetesen hagyd ki a Sheet(2)-t.
Ha több ilyen elrugaszkodási pontod van, Select Case szerkezetben adhatod meg a kiindulási pontot. A példa szerinti ugrások B1-ből D3-ba, vagy B4-ből G5-be:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Select Case Target.Address
Case "$B$4"
Application.Goto Range("G5"), Scroll:=True
Case "$B$1"
Application.Goto Range("D3"), Scroll:=True
End Select
End Sub -
#13499
Delila_1
veterán
m.zmrzlina
#13497
Delila_1
veterán
válasz
m.zmrzlina
#13497
üzenetére
Vegyük, hogy a Munka1 lap B4 cellájába tennéd a linket.
Ne tedd be, csak egy szöveget írj oda, ami utal az ugrás helyére.
A lap kódlapjára:Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$B$4" Then _
Application.Goto Sheets(2).Range("U66"), Scroll:=True
End Subfelhasználva Fire előbbi hozzászólását.
-
#13495
Delila_1
veterán
Fire/SOUL/CD
#13494
Delila_1
veterán
válasz
Fire/SOUL/CD
#13494
üzenetére
Semmi gonoszkodás, komolyan gondoltam, hogy nagy vagy!
-
#13493
Delila_1
veterán
Fire/SOUL/CD
#13491
Delila_1
veterán
válasz
Fire/SOUL/CD
#13491
üzenetére
Hurrá! Nagy vagy, mehetsz vacsorázni.
-
#13490
Delila_1
veterán
Fire/SOUL/CD
#13489
Delila_1
veterán
válasz
Fire/SOUL/CD
#13489
üzenetére
Ez is elmászik a 10. sorban.
Szerk.: szerintem jó a 13487. Több sorban ellenőriztem.
-
#13488
Delila_1
veterán
Fire/SOUL/CD
#13486
Delila_1
veterán
válasz
Fire/SOUL/CD
#13486
üzenetére
Nem jó a sorrend. Ebéd, kávé, cigi a helyes.
-
#13487
Delila_1
veterán
Fire/SOUL/CD
#13484
Delila_1
veterán
válasz
Fire/SOUL/CD
#13484
üzenetére
Ezt valakinek át kellene néznie, én már csillagokat látok tőle. Azt hiszem, ez a jó megoldás.
=DARABHATÖBB(D$2:$D31;"<" & E30;E$2:E31;">"&E30)+1
-
#13483
Delila_1
veterán
Fire/SOUL/CD
#13481
Delila_1
veterán
válasz
Fire/SOUL/CD
#13481
üzenetére
=DARABHATÖBB(D2:$D$31;"<" & E1)+1
Ezt is ellenőrizni kell több sorban.
-
#13482
Delila_1
veterán
Fire/SOUL/CD
#13481
Delila_1
veterán
válasz
Fire/SOUL/CD
#13481
üzenetére
Az első 6:24:41-kor távozott, a második ezután 28 másodperccel érkezett.
-
#13480
Delila_1
veterán
Fire/SOUL/CD
#13479
Delila_1
veterán
válasz
Fire/SOUL/CD
#13479
üzenetére
Sajnos ez sem jó. A 2. kocsi érkezésekor az első már lelépett, így az F3 cellában 1-nek kellene szerepelnie, nem 2-nek.
-
#13477
Delila_1
veterán
Fire/SOUL/CD
#13476
Delila_1
veterán
válasz
Fire/SOUL/CD
#13476
üzenetére
Tényleg nem jó, töröm a fejem a megoldáson.
Te tudod? -
Delila_1
veterán
válasz
ThaBoss
#13468
üzenetére
Ebben az esetben a lenti makróval oldd meg.
Sub Valami()
Dim sor%, sor1%, WS1 As Worksheet, WS2 As Worksheet
Set WS1 = Sheets(1)
Set WS2 = Sheets(2)
sor% = 2: sor1% = 2
WS2.Cells(sor1%, "N") = WS1.Cells(sor%, "N")
WS2.Cells(sor1%, "O") = WS1.Cells(sor%, "N")
Do While WS1.Cells(sor%, "N") <> ""
If WS2.Cells(sor1%, "N") < WS1.Cells(sor%, "O") Then
WS2.Cells(sor1% + 1, "N") = WS2.Cells(sor1%, "N") + 1
WS2.Cells(sor1% + 1, "O") = WS2.Cells(sor1%, "N") + 1
sor1% = sor1% + 1
Else
sor1% = sor1% + 1: sor% = sor% + 1
WS2.Cells(sor1%, "N") = WS1.Cells(sor%, "N")
WS2.Cells(sor1%, "O") = WS1.Cells(sor%, "N")
End If
Loop
End Sub -
#13445
Delila_1
veterán
Mythunderboy
#13444
Delila_1
veterán
válasz
Mythunderboy
#13444
üzenetére
Nincs mit.
-
#13443
Delila_1
veterán
Mythunderboy
#13442
Delila_1
veterán
válasz
Mythunderboy
#13442
üzenetére
Sehogy.
-
Delila_1
veterán
válasz
rw-ultra
#13435
üzenetére
Wordben csináld meg.
Élőfej, oldalszámozás jobbra fent. Az oldalszám formázásánál megadod a kezdő sorszámot.
Visszatérsz az élőfejből a doksiba, és ott beszúrsz néhány oldaltörést. Ahányat beszúrsz, annyi új lapot kapsz a következő sorszámmal. Az egészet kinyomtatod 2 példányban.
-
Delila_1
veterán
válasz
rw-ultra
#13433
üzenetére
Meg lehet csinálni, hogy az utoljára kitöltött cella hozza magával a sorszám növelését.
Ehhez azt kell tudni, melyik cellába írsz utoljára, és melyikben van a sorszám, valamint azt, miből áll ez a sorszám. Általában nem egy sima szám, hanem van előtte, vagy utána még betűjel, évszám, stb.
-
Delila_1
veterán
válasz
szavapart
#13425
üzenetére
Ebből az a tanulság, hogy nem szabad éles adatokkal dolgozni.
Nézd meg a formátumokat az eredetiben, és a hamis adatokat tartalmazóban!
Próbáld meg, hogy mindkét helyen (ahol beírod a keresendő számot, és ahol keresed) felszorzod 1-gyel a megadott számokat. Beírsz egy üres cellába egy 1-est, másolod, kijelölöd a telefonszámokat tartalmazó területet, jobb klikk, irányított beillesztés, szorzás.
Ezzel minden tel. számot tartalmazó cellád szám lesz, és működnie kell az FKERES függvénynek. -
#13405
Delila_1
veterán
Mythunderboy
#13402
Delila_1
veterán
válasz
Mythunderboy
#13402
üzenetére
plaschil jól írta, az End Sub elé írd be a mentős sorát.
2007-ben Mentés másként | Excel 97-2003 verziójú munkafüzet. A füzet xls kiterjesztést kap, 256 oszlop, és 65536 sor lesz az egyes lapjain.
Az IV1-ből tedd át valami középső helyre a dátumot, mert ez eléggé nyilvánvaló cím, és a felhasználók is olvashatták itt a fórumon a "nagy titkot". Megnyitás után törlik a dátumot, és végtelen ideig használhatják a nagy művedet.
-
#13401
Delila_1
veterán
Mythunderboy
#13400
Delila_1
veterán
válasz
Mythunderboy
#13400
üzenetére
Szívesen. Többszöri nekifutásra mégis sikerült közös nevezőre jutnunk.
-
#13399
Delila_1
veterán
Mythunderboy
#13398
Delila_1
veterán
válasz
Mythunderboy
#13398
üzenetére
Továbbra is a zaro változóba kell beírni, hány napig legyen érvényes a demo.
Mivel az első megnyitás dátumát csak úgy lehet megjegyezni, ha a füzet tartalmazza, az első lap IV1 cellájába írattam be, hozzáadva a zaro értéket, ez adja a lejárat napját. Ha ez a cella üres (első megnyitás), akkor bekerül oda a lejárat dátuma.
A további futtatásoknál megvizsgálja a makró, hogy az aktuális dátum >= IV1 értéknél. Ha igen, megy a védelem. Ha nem, jön a szöveg a hátralévő napok számával. Elég lenne az aktuális dátum = IV1 feltétel, de lehet, hogy aznap nem nyitják meg a fájlt.Private Sub Workbook_Open()
Dim lap%, zaro As Date
zaro = 5
If Sheets(1).Cells(1, 256) = "" Then
Sheets(1).Cells(1, 256) = Date + zaro
Exit Sub
End If
If Date >= Sheets(1).Cells(1, 256) Or Date - Sheets(1).Cells(1, 256) = 0 Then
For lap% = 1 To 5
Sheets(lap%).Select
Cells.Locked = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True, Password:="mmm"
Next
MsgBox "Megmondtam!"
Else
MsgBox (Date - Sheets(1).Cells(1, 256)) * -1 & " nap van még hátra!"
End If
Sheets(1).Select
End Sub -
#13397
Delila_1
veterán
Mythunderboy
#13396
Delila_1
veterán
válasz
Mythunderboy
#13396
üzenetére
A zaro változóban add meg a lejárat dátumát.
Private Sub Workbook_Open()
Dim lap%, zaro As Date
zaro = "2012.04.15"
If Date >= zaro Then
For lap% = 1 To 5
Sheets(lap%).Select
Cells.Locked = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True, Password:="mmm"
Next
MsgBox "Megmondtam!"
Else
MsgBox zaro - Date & " nap van még hátra!"
Exit Sub
End If
End Sub...és hogy ne kelljen a próbálgatásoknál egyenként feloldanod a lapvédelmeket, és a cellák zárolását:
Sub Felold()
Dim lap%
For lap% = 1 To 5
Sheets(lap%).Select
ActiveSheet.Unprotect Password:="mmm"
Cells.Locked = False
Next
End Sub -
Delila_1
veterán
-
Delila_1
veterán
válasz
plaschil
#13390
üzenetére
Nem adtad meg, hogy az Excelnek melyik verzióját alkalmazod.
Ha 2007-et, vagy 2010-et, akkor a Szumhatöbb függvényt használd, ha alacsonyabb verziód van, akkor fel kell venned egy segédoszlopot.
A D1 cella legyen: =A1&" "&B1, ezt másold le az adataid mellé.
Az összegző oszlop 1. cellájába ezt írd: =SZUMHA(D:D;A1&" "&B1;C:C), és másold le. -
Delila_1
veterán
válasz
jaszy83
#13388
üzenetére
Az előző makróból hagyd ki a Cells(sor, oszlop) = "K" sort, mivel manuálisan írod be.
Az uoszlop = Range("IV1").End(xlToLeft).Column sorban az egyenlőség jobb oldala helyett beírhatod fixen az 55 értéket (BD oszlop száma).A kézi bevitel után indíthatod a másik makrót, ami a BD oszlopba beírja a legnagyobb elhúzott súlyt.
Sub LegnSuly()
Dim sor%, usor As Integer, oszlop%
Sheets("Verseny").Select
usor = Range("B2").End(xlDown).Row
For sor% = 2 To usor
For oszlop% = 55 To 5 Step -1
If Cells(sor, oszlop%) = "K" Then
Cells(sor, "BD") = Cells(1, oszlop%)
Exit For
End If
Next
Next
End Sub -
Delila_1
veterán
válasz
jaszy83
#13384
üzenetére
Nem mondhatom, hogy teljesen értem, ritkán húzgálok többszáz kilós súlyokat.
Most azt gondolom, hogy amelyik súly szerepel a Felvitel lap D oszlopában a név mellett, ahhoz a súlyhoz kell K-t írni a Munka3 lapon.
De honnan jön a H?
Makró:
Sub Rendez_2()
Dim sor As Long, usor As Long, oszlop As Integer, uoszlop As Integer
Dim WS As Worksheet, WSF As Worksheet
Application.ScreenUpdating = False
Set WS = Sheets("Munka3") '***************
Set WSF = Sheets("Felvitel") '***************
usor = WSF.Range("A" & Rows.Count).End(xlUp).Row
WS.Select
uoszlop = Range("IV1").End(xlToLeft).Column
'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
WSF.Select
Range("A2:C" & usor).Copy WS.Range("A2")
WS.Select
'Rendezés
Range(Cells(1, 1), Cells(usor, uoszlop)).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, "–" beírása
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
For oszlop = 5 To uoszlop
If Cells(1, oszlop) < WSF.Cells(sor, 4) Then
Cells(sor, oszlop) = "–"
Else
Cells(sor, oszlop) = "K"
Exit For
End If
Next
Next
'Keret
Range(Cells(1, 1), Cells(usor, uoszlop)).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
Application.ScreenUpdating = False
End Sub -
#13380
Delila_1
veterán
Mythunderboy
#13379
Delila_1
veterán
válasz
Mythunderboy
#13379
üzenetére
Az End Sub fölé:
MsgBox "Ráfaragtál, Öcsi!"
-
#13378
Delila_1
veterán
Mythunderboy
#13377
Delila_1
veterán
válasz
Mythunderboy
#13377
üzenetére
Szívesen.
A If Date > "2012.04.01" Then sorban állíthatod kedved szerint a dátumot.
Ha a mainál előbbit állítasz be, lefut a makró (akkor a lapok védettségét az "mmm" jelszóval fel tudod oldani, a cellák zárolását pedig az összes cella kijelölésével, és a formátumnál a "Zárolás" megszüntetésével).
Ha későbbit írsz ebbe a sorba, marad minden úgy, ahogy volt. -
#13373
Delila_1
veterán
Mythunderboy
#13372
Delila_1
veterán
válasz
Mythunderboy
#13372
üzenetére
Azt hittem, mást is csinál a makró a lapvédelmen kívül.
A VB szerkesztőben bal oldalon a ThisWorkbook-ra duplán kattintasz, mire jobb oldalon kapsz egy üres lapot, oda másold be az alábbi kódot.
Ez minden lap minden celláját zárolja, és a hangzatos "mmm" jelszóval védetté teszi a lapokat. Adj helyette normálisat.
Mit értsek azon, hogy "adatokat megadni ne tudjanak"?
Private Sub Workbook_Open()
Dim lap%
If Date > "2012.04.01" Then
For lap% = 1 To 5
Sheets(lap).Select
Cells.Locked = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True, Password:="mmm"
Next
Else
Exit Sub
End If
End Sub -
#13370
Delila_1
veterán
Mythunderboy
#13366
Delila_1
veterán
válasz
Mythunderboy
#13366
üzenetére
A VB szerkesztőben a ThisWorkbook-hoz rendeld.
Private Sub Workbook_Open()
If Date > "2012.04.02" Then
Exit Sub
Else
'***** Ide jön, amit vérge akarsz hajtatni, ha nem járt le a dátum
End If
End SubÉrdemes a makrót levédeni a szerkesztőben a Tools | VBAProject- Properties | Protection fülön, ahol jelszóval tudod letiltani a megnyitását.
-
Delila_1
veterán
válasz
jaszy83
#13364
üzenetére
Azt majd megmondod, mi az X és H az egyes sorokban.
Sub Rendez_1()
Dim sor As Long, usor As Long, oszlop As Integer, uoszlop As Integer
Dim WS As Worksheet, WSF As Worksheet
Application.ScreenUpdating = False
Set WS = Sheets("Munka3") '***************
Set WSF = Sheets("Felvitel") '***************
usor = WSF.Range("A" & Rows.Count).End(xlUp).Row
WS.Select
uoszlop = Range("XFD1").End(xlToLeft).Column
'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
WSF.Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Copy WS.Range("A2")
WS.Select
'Rendezés
Range(Cells(1, 1), Cells(usor, uoszlop)).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, "–" beírása
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
For oszlop = 5 To uoszlop
If Cells(1, oszlop) < Cells(sor, 4) Then
Cells(sor, oszlop) = "–"
Else
Exit For
End If
Next
Next
'Keret
Range(Cells(1, 1), Cells(usor, uoszlop)).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
Application.ScreenUpdating = False
End Sub -
Delila_1
veterán
-
Delila_1
veterán
válasz
jaszy83
#13345
üzenetére
Gyorsabb futást eredményez az újabb makró, és csak a két lap nevét kell módosítani, meg esetleg az 5000 sort.
Sub Rendez()
Dim sor As Long, usor As Long, oszlop As Integer
Dim WS As Worksheet, WSF As Worksheet
Application.ScreenUpdating = False
Set WS = Sheets("Munka3") '***************
Set WSF = Sheets("Felvitel") '***************
usor = WSF.Range("A" & Rows.Count).End(xlUp).Row
WS.Select
oszlop = Range("XFD1").End(xlToLeft).Column
'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
WSF.Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Copy WS.Range("A2")
WS.Select
'Rendezés
Range(Cells(1, 1), Cells(usor, oszlop)).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(Cells(1, 1), Cells(usor, oszlop)).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
Application.ScreenUpdating = False
End Sub -
Delila_1
veterán
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 -
#13324
Delila_1
veterán
Fire/SOUL/CD
#13323
Delila_1
veterán
válasz
Fire/SOUL/CD
#13323
üzenetére
Összeadta, de gyalog. Ahelyett kellene valami képlet.
Próbáltam szétválogatás nélkül így: =SZUMHA(B:B;B3&"*";A:A), megy így =SZUMHA(B:B;"*"&B3&"*";A:A), de hol jó, hol rossz összeget ad. A két képlet azonos soroknál téved. Vagy én...?
Szerk. Persze, hogy én tévedek, hiszen a B3 pl. szeder (5), és abból nincs több.
-
#13322
Delila_1
veterán
Fire/SOUL/CD
#13321
Delila_1
veterán
válasz
Fire/SOUL/CD
#13321
üzenetére
Igen, de a banán egyszer banán (3), másszor banán (8) néven szerepel. Ezért előbb szét kell választani a cella két részét.
Penty!
Másold át a B oszlopot egy kicsit jobbra, ahol van üres helyed. Én az F oszlopba másoltam. Kijelölöd, Szövegből oszlopok, Tagolt, határolójel szóköz, Befejezés. Ez kétfelé választja az F oszlop tartalmát. Jöhet a képlet a C1-be:
=SZUMHA($F$1:$F$12;F1;$A$1:$A$12)
Azt nem tudom, a Te programodban hol találod meg a Szövegből oszlopok funkciót.
-
-
Delila_1
veterán
válasz
jaszy83
#13277
üzenetére
Munka2!A2 -> =Munka1!A2, ezt jobbra húzod C2-ig.
Munka2!D2 -> =FKERES(C2;$G$1:$H$12;2;0), feltéve, hogy a súlytáblázat a $G$1:$H$12 tartományban van ezen a lapon, G-ben súly, H-ban kategória.
Munka2!E2 -> =D2+SOR()*0,00001
Az A2:E2 tartományt lemásolod addig, ameddig adat van a Munka1 lapon.
Munka3!A2 ->
=INDEX(Munka2!$A:$D;HOL.VAN(KICSI(Munka2!$E:$E;SOR()-1);Munka2!$E:$E;0);4).Ezt jobbra másolod C2-ig, majd a B2-ben az utolsó paramétert, a 4-et átírod 1-re, C2-ben pedig 2-re. A három cellát lemásolod, ameddig kell.
![;]](http://cdn.rios.hu/dl/s/v1.gif)
Új hozzászólás Aktív témák
Fferi50- Milyen asztali (teljes vagy fél-) gépet vegyek?
- Folyószámla, bankszámla, bankváltás, külföldi kártyahasználat
- Luck Dragon: Asszociációs játék. :)
- Hosszú premier előzetest kapott az Arknights: Endfield
- CURVE - "All your cards in one." Minden bankkártyád egyben.
- Vezeték nélküli fülhallgatók
- Milyen külső akkumulátort mobileszközökhöz?
- Kormányok / autós szimulátorok topikja
- Facebook és Messenger
- Meghozta a régóta várt asztali Ryzen APU-kat az AMD
- További aktív témák...
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- MEGA AKCIÓ! - Jogtiszta Windows - Office & Autodesk & CorelDRAW - Azonnal - Számlával - Garanciával
- Windows 10/11 Home/Pro , Office 2024 kulcsok
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- LG 77C4 - 77" OLED evo - 4K 144Hz - 0.1ms - NVIDIA G-Sync - FreeSync - HDMI 2.1 - 1000 Nits
- iPhone Xr 64GB 100% ÚJ EREDETI AKKUMULÁTOR Gyűjtői darab (3hónap Garancia)
- Telefon felvásárlás!! Samsung Galaxy S21/Samsung Galaxy S21+/Samsung Galaxy S21 Ultra
- MikroTik / hálózati eszközök több típus, készletről
- Telefon felvásárlás!! iPhone 12 Mini/iPhone 12/iPhone 12 Pro/iPhone 12 Pro Max
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest