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

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Mivel errefelé rendkívül segítőkész emberkék kószálnak, ezért ismét bátorkodnék zavarni...
Adva van az alábbi képen látható két oszlop: Az A oszlopban pénzösszegek vannak (bevételek és kiadások), a B oszlopban pedig dátumok.
Ahogy az látható a képen, a negatív és a pozitív számokat (kiadásokat és bevételeket) sikerült szétválasztanom és megszámolnom külön-külön az E1 és E2 cellákban. Sikerült külön-külön szétválasztanom és megszámolnom a januári, februári és márciusi pénzeket is az E3-E5-ig terjedő cellákban, de van velük egy kis bibi: Szeretnem ezeket a hónapokra lebontott számokat is külön-külön negatív és pozitív számokra tovább bontani, hogy meg tudjam külön számolni a januári, februári, márciusi kiadásokat és bevételeket is.
A Libre Office-ben nem találtam SZUMHATÖBB függvényt, így valami más megoldás kellene. Nem baj, ha az Excel képlet kicsit eltér a Calc-os képlettől: a különbségeket ki tudom majd bogarászni.
Segítségeteket előre is köszönöm!

Vegyél fel két oszlopot, amik külön választják a bevételt és a kiadást.
Bevétel -> =HA(B2>0;B2;"")
Kiadás -> =HA(B2<0;B2;"")

Ezekből már készíthetsz kimutatást. Az Excelben lehet a dátumoknak tagolást adni, ami például hónapok szerint mutatja az összegeket.

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Sziasztok

Van egy hosszabb makróm, amiből kivettem most egy pár sort:

s = s + 1
Cells(s + 1, 11).Value = DateValue(Now)
Cells(s + 1, 12).Value = Cells(m + 1, 1).Value
Cells(s + 1, 13).Value = "A"
Cells(s + 1, 14).Value = 48
s = s + 1
Cells(s + 1, 11).Value = DateValue(Now)
Cells(s + 1, 12).Value = Cells(m + 1, 1).Value
Cells(s + 1, 13).Value = "A"
Cells(s + 1, 14).Value = 49
s = s + 1
Cells(s + 1, 11).Value = DateValue(Now)
Cells(s + 1, 12).Value = Cells(m + 1, 1).Value
Cells(s + 1, 13).Value = "A"
Cells(s + 1, 14).Value = 31
Cells(s + 1, 15).Value = "ID"
s = s + 1
Cells(s + 1, 11).Value = DateValue(Now)
Cells(s + 1, 12).Value = Cells(m + 1, 1).Value
Cells(s + 1, 13).Value = "A"

A félkövérrel kiemelt rész ismétlődik elég sokszor.
Van arra lehetőség, hogy ez csak egyszer szerepeljen a kódban, amit mindig meghívok a megfelelő helyen?

SonyEricsson T20 - T68 - T610 - K700 - W800 - K750 - K800 - C702 - P1 - MOTO Defy - Galaxy S Advance - Galaxy S4 - Lumia 820 - Honor 7 - iPhone 5S

Delila Köszi, az elsőt használom működik,
a gondom viszont elképesztően banális problémával szenvedek már egy napja.
a felvitel lapomon ahhoz hogy automatikusan kiszámolja a sulykategóriát ez a függvényt használom:
=HA(Rögzítés!A18=(0); "";FKERES(Rögzítés!B18;$G$2:$H$12;2))

az általad írt függvényt már egy tiszta lapról használnám ahol csak és kizárólag a három szükséges adat lesz rajta, a súlykategória, a név és a súly. Ehhez a felvitel lapról másolom az értékeket a Munka2 lapra

Sheets("Felvitel").Select
Columns("B:B").Select
Selection.Copy
Sheets("Munka2").Select
Columns("C:C").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Így viszont a fenti HA függvény eredményeként másolja a semmit is, és az összesítésnél lesz néhány ami jó adat, ahol tartalmaz versenyző adatokat, viszont lesz nagyon sok olyan, ami üres adat, de ezt is keretezi és összevonja a semmit.
Valami olyasmi kellene ami csak akkor másol ha nem 0 vagy nem " " vagy nem tudom. Elakadtam..

A Cells(s + 1, 13).Value = "A" sor is ismétlődik. Direkt hagytad ki?

Amúgy megoldható SUB-al, csak az s változót publikusként kell deklarálni

Mindenki tudja, hogy bizonyos dolgokat nem lehet megvalósítani, mígnem jön valaki, aki erről nem tud, és megvalósítja. (Albert Einstein)

Én így oldanám meg ezt a feladatot

Public s As Integer, m As Integer

Sub MySubRoutine(MyIndex_s As Integer, MyIndex_m As Integer, Optional MyValue As Variant, Optional MyString As Variant)

Cells(MyIndex_s + 1, 11).Value = DateValue(Now)
Cells(MyIndex_s + 1, 12).Value = Cells(MyIndex_m + 1, 1).Value
Cells(MyIndex_s + 1, 13).Value = "A"
If Not IsMissing(MyValue) Then Cells(MyIndex_s + 1, 14).Value = MyValue
If Not IsMissing(MyString) Then Cells(MyIndex_s + 1, 15).Value = MyString

End Sub


Sub MyMainCode()

s = s + 1
MySubRoutine s, m, 48
s = s + 1
MySubRoutine s, m, 49
s = s + 1
MySubRoutine s, m, 31, "ID"
s = s + 1
MySubRoutine s, m

End Sub

[ Szerkesztve ]

Mindenki tudja, hogy bizonyos dolgokat nem lehet megvalósítani, mígnem jön valaki, aki erről nem tud, és megvalósítja. (Albert Einstein)

Végül nem mókoltam, mert csak 8 helyen szerepel ugyanaz a 4 sor.
Nem sok.

Most olyan bajom van, hogy "Could not find the specified object" üzit dob nekem erre a sorra:
If Form1.Controls("man_" & m).Value = False Then

a Form1-en van 30 db ToggleButton, amiknek a neve man_1, man_2, stb...
Az m egy for ciklus változója.

Egyébként helyesen lefut a makró, de a végén ezt az üzit bevágja.
Mi lehet baja?

SonyEricsson T20 - T68 - T610 - K700 - W800 - K750 - K800 - C702 - P1 - MOTO Defy - Galaxy S Advance - Galaxy S4 - Lumia 820 - Honor 7 - iPhone 5S

Dupla idézőjelről feledkeztél meg Írd be próbaképp direktbe hogy pl
If Form1.Controls("man_1").Value = False Then

Így elfogadja a man_1-et

Mindenki tudja, hogy bizonyos dolgokat nem lehet megvalósítani, mígnem jön valaki, aki erről nem tud, és megvalósítja. (Albert Einstein)

Ááá, bocsi, hülyeséget írtam...
Szóval az lehet a gond, hogy az m ciklusváltozód olyan értéket vesz fel (man_m), amilyen nevű objektum nincs a userform-on. Valószínűleg a for ciklusod 1-el (vagy többel) tovább szalad, mint kellene. (Ahogy írtad 1-től 30-ig kellene futni a ciklusnak)

[ Szerkesztve ]

Mindenki tudja, hogy bizonyos dolgokat nem lehet megvalósítani, mígnem jön valaki, aki erről nem tud, és megvalósítja. (Albert Einstein)

Sziasztok!

Tud valaki megoldást az office 2007 vs "régi" XLS "Fájlhiba, az adatok elveszhetnek!" problémára? Most épp egy 50 megás fájlban sikerült neki random kitörölni egyetlen mezőt és ezzel gallyra vágni az egészet és még csak nem is képlet volt benne, egyszerű érték.

"I love not man the less, but Nature more" // Giant TCR Adv. '16 Di2 // Fenix 7 SS // FiiO BTR3 + Truthear ZERO

problem solved,
büszke vagyok magamra, sikerült fkeres makróval abszolválni hogy negyedik adatnak vigye fel a súlykategóriát:

Sheets("Rögzítés").Cells(hova, 4) = Application.VLookup(suly, Range("Felvitel!$G$2:$H$12"), 2)

Viszont újabb segítségre lenne szükségem:

Az adatok lapon felvitt harmadik, kulcsadat a kezdősúly.
Az itt megadott adatot kellene úgy felhasználni, hogy pl. ha kezdősúlynak 700-at írok be, akkor 600-ig a versenylapon adott versenyző sorába egy minuszt rakjon 600ig (valami olyasmire gondolok hogy a 700 lenne a megadott parameter, amire szükségünk van, az az hogy hány oszlopba írjon adott sorban (tehát a versenyző sorában) E oszloptól kezdve. Mivel E oszloptól indulnak a súlyok 500 kilótól, ezért a képlet a "(parameter-500)/100" lehetne, ez így a példa 700 kilónál 2-t ad ki, és innen valami do-until jellegű dologgal (vagy egyéb lehetséges módon) E oszloptól adott sorban írna minuszt.
Na ezt így remélem sikerült érthetően leírni kicsit fáradt vagyok.. ;
előre is köszi a segítséget!

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

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Sziasztok!
Lenne egy talán idétlennek tűnő kérdésem Az aktuális dátumot a "MA()" függvénnyel elhelyeztem egy munkalapon.Van e lehetőség arra ha a dátum elér egy általam megadott adott napot akkor indítson egy lapvédelmet így használhatatlanná tegye? Mint egy demo verzió aminek lejár a licensze?

Spacesynth 4 ever!

Sziasztok!

van egy elég nagy adathalmazom melyben betűkódok alapján dátumhoz és órához (negyed órás bontásban) vannak az infók hozzárendelve. úgy néz ki, hogy betűkód, dátum, idő és utána még kb 15 cella különbözö értékek egy sorban. azt szeretném vhogy összehozni, hogy szedje ki minden egyes negyed órában, hogy adott betűkódhoz pl a H oszlopban milyen érték tartozik. annyiva viszont bonyolódik, hogy a betűkódok csoportokat alkotnak, így pl. 7:30-hoz nem csak a 13-as tartozik, hanem másik 5 is.
ha esetleg valaki tudna segíteni, azt megköszönném!
(elnézést, ha kuszán fogalmaztam )

Szia!
Makróval biztos megoldható, de ebben csak a nagy tudásúak tudnak majd segíteni!

Bámulatos hol tart már a tudomány!

Vmilyen képet tudnál mutatni az elképzelésről

Bámulatos hol tart már a tudomány!

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.

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

=SZUMHATÖBB($H$1:$H$700,$C$1:$C$700,AA3,$A$1:$A$700,13)

eddig ezzel próbálkoztam
csak a második kritériumtartomány a harmadik, negyedik... kritériumtartománynál is ua lenne, de úgy persze már nem működik a képlet
esetleg vmilyen makro is jó lenne, de azokhoz abszolút nem konyítok

Köszi Delila!
Lenne két kérdésem:
Egy két makrót már megírtam a segítségeddel de még nem nagyon vágok pár dolgot.
1, A " This Workbook"-hoz hogyan rendelem? (Ez az adott munkalap lenne amin alkalmaznám?)
2,Amit végre akarok hajtani ha nem jár le a dátum, tehát hibátlanul működik, az 5 munkalapon van és egymáshoz kapcsolódnak ezt hogyan kellene megírnom a makróban?

Vagyis 5 munkalapot kellene "lezárni" egyszerre ,hogy se beleírni se adatokat megadni ne tudjanak.....
Vagy valamit nem jól csinálok? A makrólevédés az menni fog.

Spacesynth 4 ever!

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

[ 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.

Na jó, kezd az agyamra menni az excel2007 az ő összes fájlformátumával

Adott egy eddig jól működő A.xls és egy eddig jól működő B.xlsm. Az utóbbiban egy függvény van megírva, és ezzel a függvénnyel hivatkozik az előbbire (egyfajta fkeres-szerűség ). ebben a felállásban eddig minden szép és jó volt.

1) Az A.xls elkezdett "Fájlhiba, az adatok elveszhetnek" hibákat dobni.
2) A.xlsm-ként mentve a B.xlsm-ben hivatkozás frissítésekor vagy "forrás nem található" vagy hibával elszáll az egész hóbelevanc.
3) A.xlsx-ként mentve mindig elszáll hibával hivatkozás frissítésnél.
4) B.xlsx-ként nem menthető, mert kinyírja a makrót.

Egyéb lehetőség? Sem kedv, sem idő nem lenne az A fájlt újra nulláról megcsinálni egy üres .xlsx vagy .xlsm-ben (csak a miheztartás végett, ez egy .xls-ként 54, .xlsx-ként 15 megás fájl).

[ Szerkesztve ]

"I love not man the less, but Nature more" // Giant TCR Adv. '16 Di2 // Fenix 7 SS // FiiO BTR3 + Truthear ZERO

Szia Delila, az X az a sikeres húzás, a H pedig hiba lenne... D oszlopban pedig majd számolja a hibákat

Viszont amit írtál az nekem hibát jelez:
Run-time error '1004':
Method 'Range' of object '_Global' failed

és erre a sorra írja:
uoszlop = Range("XFD1").End(xlToLeft).Column

mi lehet a baja?

Az, hogy kevesebb oszlopod van. Legyen a sor
uoszlop = Range("IV1").End(xlToLeft).Column

A makróban úgy vettem, hogy a kezdősúly a Felvitel lap D oszlopában van.

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Köszi Delila! Ismét
Az " adatokat megadni ne tudjanak" azt jelentené amit gyakorlatilag csinálni kéne a makrónak ,de ha jól értelmezem akkor pont ezt fogja csinálni tehát pont ilyenre gondoltam....letesztelni vajon hogyan tudnám? mert ha a mai dátumot adom meg hibaüzenetet ad de a holnapival már fut....vagy várjak holnapig

Spacesynth 4 ever!

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.

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Műxik!! ....Arra van lehetőség hogy valami ablakban egy hibaüzenet megjelenjen hogy "Lejárt a próbaidő" vagy valami hasonló?.....(csak hogy tudja emberünk miért nem tudja használni) ......Így lenne a leg tutkóbb

Spacesynth 4 ever!

Az End Sub fölé:

MsgBox "Ráfaragtál, Öcsi!"

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Spacesynth 4 ever!

Sziasztok, tartomány témában kérnék segítséget.
Outlook-ba importálnék be egy xls-ben lévő címlistát. De az Outlook azt mondja nem tudja importálni a fáj tartalmát, mert nincsenek tartományok meghatározva. Hozzam létre őket Excel-ben.
2003-mas változatot használok mindkét programból, Excel-ben megcsináltam, amit a SÚGÓ mond/mutat, de mikor a =OFSZET($A$2,0,0,DARAB2($A$2:$A$200),1) képletet bírom a felugró ablakba, és leokéznám, csak annyit mond: "A beírt képlet hibás.", és nem tudom mihez kezdjek vele.
Egyébként egyszerű a fájlom tartalma, A oszlopban nevek vannak, B oszlopban meg e-mail-ek.

[ Szerkesztve ]

Na végül megoldottam .csv formátumban, úgy hogy minden adatot kitöröltem, kivéve az e-mail címeket, így már egy fokkal egyszerűbb volt, szóval tárgytalan.

Lenne itt viszont egy másik apróság.
Mappaszerkezetet hogyan tudok exportálni? A beérkező üzeneteken belül hoztam létre vagy 50-et, amit nagyon nem szeretnék minden gépen megcsinálni. Végülis a szűrőkhöz/szabályokhoz tartozó mappák ezek, ahova automatikusan kerülnek a bejövő üzenetek.

[ Szerkesztve ]

Delila köszi megint, működik, mostmár látom a végét.

Tehát most a helyzet:
Első sorban feltüntetve növekvő sorrendben a súlyok (pl: 500; 600; 700 stb)
alatta sorokban vannak a versenyzők, nyilvántartva a húzásaikat:
k a sikeres húzás, h a hiba, minusz a kihagyott súly
Tehát például adott versenyző sora így néz ki:

- - - K - - K - - H - - K - - H

a feladat az lenne, hogy a legnagyobb elhúzott súlyt függvényként megjelenítsem, tehát lefordítva excelesre, adott sor LEGJOBBRÁBB elhelyezkedő "K" (sikeres húzás) oszlopából az első sor (elhúzott súly) adatát szerepeltesse. Próbálkoztam egy ilyesmivel de valamiért ez nem helyes adatot ad (a legkissebb elhúzott súlyt adja, tehát a legbalrábban lévő "k"-t):

=INDEX($E$1:BC1;1;MAX(HOL.VAN("k";E11:BC11;0)))

(a súlyozás E oszloptól indul, ahogy a rögzítés is, előtte adatok vannak)
mi lehet a baja? a max nem pont hogy a legnagyobbat kéne adja? (ráadásul kipróbálva a MAX helyett MIN-re is ugyanezt a legkisebbet adja)

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

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Köszönöm szépen a választ, Delila_1!
Sikerült megcsinálnom a táblázatomat az általad írt segítséggel sőt, még tovább is bontottam a dolgot mind a kiadási, mind a bevételi oldalon...
Köszi még egyszer a segítséget!

Szívesen.

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, bocsánat úgy látszik túl fáradt voltam hogy sikerüljön világosan fogalmaznom
A képlet az már jó volt úgy köszi neked, a menet a következő:
1. felvittük az adatokat, önsúlyból automatikusan kiszámolja melyik súlykategória,
majd a második makró sorbarendezi őket ahogy kell és átrakja verseny lapra.

2. Innentől manuális a kezelése, a belépősúllyal kezd a versenyző, ha elhúzza akkor a sorába beírok egy K-t, ha hibézik akkor H-t. Így megy tovább, sikeres húzás esetén mehet tovább, ha következő választott súlyt kihagyja akkor megint K-t írok a sorába stb, egész addig, amíg az utolsó sikeres húzásra írok be neki K-t , többet már nem bír elhúzni. Legyen ez mondjuk 4000 kiló az egyik versenyzőnél. A sorok végére akartam írni egy olyan függvényt, ami a legnagyobb elhúzott súlyt írja ki adott versenyzőnél, tehát hogy az első sor (ahol a súlyok vannak növekvő sorrendben) azon adatát írja be a függvény mezőbe abból az oszlopból, amelyik a legtöbb elhúzott súly a versenyző sorában, tehát amelyik legjobbra helyezkedik el.
(nálam VERSENY lapon első sor E oszloptól kezdődik 500 kilótól a súly, és tart 100 kilónként BC oszlopig, 5500ig, innen kell kinyerni az adatot abból az oszlopból, ahol a versenyző sorában a verseny végén az utolsó K (sikeresen elhúzott súly) van).
na azt hiszem jól leírtam, remélem így érted mit szerenék.

Na erre írtam én a
=INDEX($E$1:BC1;1;MAX(HOL.VAN("k";E11:BC11;0)))
függvényt, ami nem akar működni...
előre is köszi a segítséged!

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

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Sziasztok!

Segítséget szeretnék kérni egy makró megírásához. Adott egy lista. Ez tartalmaz több karakterkódot (ez most mindegy mi, pl. "ABC", "CAB", "CBA" hasonlók...), és ezekhez tartozik egy másik kód (ez most mindegy mi, pl "1234", "9876", "1243" hasonlók... de nem integer, mert pont is van benne, csak az egyszerűség kedvéért adtam meg így).
Így lesz egy olyan listám ami pl. így néz ki:
ABC 1234 5
ABC 1234 6
ABC 4321 2
ABC 4321 2
CBA 1234 1
CBA 1234 5
stb...
Na most az azonos "ABC"-k azonos kódjai mellett van egy szám (aláhúztam) ezeket szeretném összeadni.
Vagyis ABC 1234 esetén azt adja vissza nekem hogy:
ABC 1234 11
ABC 4321 esetén azt hogy:
ABC 4321 4
És így tovább, mint egy pivot, csak aztán nekem még mahinálnom kell az adatokkal és 100x egyszerűbb lenne ha egy makró adná ezt vissza nekem.

Hú, érthető ez így? :S

Creative G500 vezérlő panelt keresek// Hol vagy helyileg? - A kisszobába. // Szilvásbuktát, mert azt szeretem!

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.

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Ha jól látom miután készen van, csak a duplikációkat kell kiszednem és ugyanazt kapom mint egy pivotból.

Nagyon szépen köszönöm, eddig nem ismertem ezt a függvényt, nem régóta dolgozom excel-ben, de lehet ezt a függvényt tudom alkalmazni egy másik problémámnál.

Mégegyszer köszönöm!
Ja és ha már itt vagyok, a sok segítségért cserébe:

Hogy el ne hervadj!

Creative G500 vezérlő panelt keresek// Hol vagy helyileg? - A kisszobába. // Szilvásbuktát, mert azt szeretem!

Köszönöm!

Régebben már írtad az általad alkalmazott Excel verzióját, de nem jegyeztem meg. Láttam valakinél, hogy az adatainál az Aláírás rovatba írta be, jó ötletnek tartom.

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Sziasztok!

Még mindig nem sikerült megoldanom, egy kis segítséget én is megköszönnék!

Hozz létre egy kimutatást az adataidból!

A Sorcímkékhez tedd be az A és a C oszlop címét, a Jelentésszűrőbe a B-ét, az Értékekhez a H-ét.
A sok összegző sor zavaró lehet. Ezek egyikén jobb klikk, Mezőbeállítások, a Részösszegek közül a Nincs választót jelöld be.

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Sziasztok!
Delila szeretném "továbbfejleszteni" a dátumos makrót .Olyan formában ha lehetséges ,hogy a lap legelső megnyitásakor rögzítené az aznapi dátumot és innentől számítva egy szövegdobozban mindíg megjelenítené hány napig használható még a program.Amikor letelik akkor zárná le véglegesen a lapvédelemmel....Azt hogy hány napig használható azt külön meg lehetne határozni. Ilyen szerinted megoldható lenne?

[ Szerkesztve ]

Spacesynth 4 ever!

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

Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

Köszönöm a gyors választ! Lehet nem jól fogalmaztam ,de igazándiból úgy gondoltam,hogy nem a dátumot adnám meg ameddig érvényes,hanem azt az időt ahány napig tudja használni.(Ez több emberhez is elkerülne és valaki korábban valaki később nyitja meg először .Az első megnyitáshoz hozzáadná annyi napot ahány napra be van állítva , és addig lenne használható)
Így is megoldható? (A "felold" makro nagyon jó ötlet ,és igen hasznos lett)

Spacesynth 4 ever!

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

[ 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.

Nagyon KÖSZÖNÖM!!

Spacesynth 4 ever!