- OnePlus One - Kína már itt One
- Milyen okostelefont vegyek?
- Csak semmi szimmetria: flegma dizájnnal készül a Nothing Phone (3)
- Bemutatkozott a Poco X7 és X7 Pro
- One mobilszolgáltatások
- Google Pixel topik
- Apple iPhone 15 Pro Max - Attack on Titan
- Huawei Watch Fit 3 - zöldalma
- CMF Buds Pro 2 - feltekerheted a hangerőt
- Samsung Galaxy S25 Ultra - titán keret, acélos teljesítmény
-
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
-
#37717
Delila_1
veterán
customer114
#37716
Delila_1
veterán
válasz
customer114
#37716
üzenetére
Az Excel 2007-es verziójától kezdve lehet színre szűrni. Szűrd az oszlopot, majd a szűrt állományt másold át a másik lapra.
-
Delila_1
veterán
válasz
d@minator
#37712
üzenetére
A gombokat csoportba foglalod, és a Csoport neved adod neki.
Ez a laphoz rendelt makró az A3:D100 cellák bármelyikére kattintva mindig "kéz alá" teszi a csoportodat.
Írd át a kiválasztott területet a saját igényed szerint.Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, [A3:D100]) Is Nothing Then
ActiveSheet.Shapes("Csoport").Top = ActiveCell.Top - 20
ActiveSheet.Shapes("Csoport").Left = ActiveCell.Left + ActiveCell.Width + 20
End If
End Sub
Az RGB kódhoz: keverd ki háttérnek a kedvenc árnyalatodat, és jegyezd meg az RGB értékeket. A makróban így adhatod meg
Selection.Interior.Color = RGB(100, 200, 170) -
Delila_1
veterán
válasz
tzimash
#37680
üzenetére
Nem kellenek gombok, elég egy, a laphoz rendelt makró.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim oszlop As Long, sor As Long, B, C, E, F, I
sor = Selection.Row
Range("A1").CurrentRegion.Interior.Color = xlNone
Range("A" & sor & ":I" & sor).Interior.Color = vbYellow
B = Cells(sor, "B")
C = Cells(sor, "C")
E = Cells(sor, "E")
F = Cells(sor, "F")
I = Cells(sor, "I")
MsgBox B & vbLf & C & vbLf & E & vbLf & F & vbLf & I
End SubAz üzenet (Msgbox) helyett műveleteket végezhetsz az aktív sor celláinak az értékével.
-
-
Delila_1
veterán
-
Delila_1
veterán
válasz
p5quser
#37629
üzenetére
Sorban megnyitod egy mappa adatait. Az egyes füzetek megnyitása után hívd meg ezt a makrót.
Sub Kigyujtes()
'B oszlopban szűrünk az "elszámolás" szóra.
'A szűrt adatok közül a szűrés előtti, a szűrt oszlop, és a szűrés utáni oszlop
'adatait másoljuk az Összesítés lap első üres sorába, a lap B oszlopától kezdve.
'Az Összesítő A oszlopába beírjuk a lap nevét, ahonnan másoltunk. Megszüntetjük a szűrést.
'Az Összesítő az utolsó lap a füzetben.
Dim lap As Integer, innen As Long, eddig As Long, WSO As Worksheet
Set WSO = Sheets("Összesítés")
Application.ScreenUpdating = False
For lap = 1 To Sheets.Count - 1
Sheets(lap).Activate
Range("$A:$F").AutoFilter Field:=2, Criteria1:="elszámolás"
Range(Cells(2, 1), Cells(10000, 3)).SpecialCells(xlCellTypeVisible).Copy
innen = WSO.Range("B" & Rows.Count).End(xlUp).Row + 1
WSO.Range("B" & innen).PasteSpecial xlPasteValues
eddig = WSO.Range("B" & Rows.Count).End(xlUp).Row
WSO.Range("A" & innen & ":A" & eddig) = ActiveSheet.Name
Range("$A:$F").AutoFilter Field:=2
Next
WSO.Activate: Range("A2").Select
Application.ScreenUpdating = True
End SubBiztosan hozzá tudod idomítani a saját igényeidhez.
-
-
Delila_1
veterán
válasz
tgumis
#37547
üzenetére
A védelmet az értékadások alá tedd!
'értékadások
Set WSBev = Sheets("bevitel")
Set WSOsz = Sheets("ÖSSZESÍTÉS")
Bsor = WSOsz.Range("B" & Rows.Count).End(xlUp).Row + 1
usor = WSBev.Range("D2").End(xlDown).Row
'lapok védelmének feloldása a makró számára
WSBev.Protect Password:="pw", UserInterfaceOnly:=True
WSOsz.Protect Password:="pw", UserInterfaceOnly:=True -
Delila_1
veterán
válasz
tgumis
#37542
üzenetére
A hiba azért lépett fel – amire korábban felhívtam a figyelmedet –, mert a makró végén a bevitel lap jelszavát módosítottuk pw-ről LiliLufi140127-re. Ha továbbra is meg akarod hagyni a pw-t, akkor az utolsó utasítást egyszerűen töröld ki a makróból.
Ezt kell kihagynod.
WSBev.Protect Password:="LiliLufi140127", UserInterfaceOnly:=True, _
AllowFiltering:=True, AllowFormattingColumns:=TrueÚgy tűnik, hiába írtam le már többször, hogy a
WSBev.Protect Password:="pw", UserInterfaceOnly:=True
WSOsz.Protect Password:="pw", UserInterfaceOnly:=Truesorok a 2 lapot a makró számára írhatóvá teszik, nem kell külön a makró elején felszabadítani, a végén pedig védetté tenni a lapokat.
-
Delila_1
veterán
válasz
logitechh
#37539
üzenetére
Sok helyen használod a Select utasítást, amik lassítják a program futását. Pl. a
Range("D2:T" & usor).Select
Selection.Copysorok helyett elég a
Sheets("bevitel").Range("D2:T" & usor).CopyHa itt nem értéket, hanem teljes tartományt kellene beilleszteni, ugyanebben a sorban megadhatod a célt is.
Sheets("bevitel").Range("D2:T" & usor).Copy Sheets("ÖSSZESÍTÉS").Range("C" & Bsor)Azt már írtam Tgumis-nak is, hogy a
Lapneve.Protect Password:="pw", UserInterfaceOnly:=Truesor a makró részére írhatóvá teszi a lapot, nem kell külön a makró elején feloldani, majd a végén újra levédeni.
Msgbox a folytatáshoz:
Sub Kerdes()
Dim valasz
valasz = MsgBox("Futtassam a Másik makrót?", vbYesNo + vbQuestion, "Futtatási kérdés")
If valasz = vbYes Then Masik_Makro ' itt hívjuk meg a feladat végrehajtó makróját
End SubSub Masik_Makro()
MsgBox "Ez itt a Másik makró"
End Sub -
Delila_1
veterán
válasz
tgumis
#37537
üzenetére
A makró elejére beírtam a kérdést, a vége felé meg ott van a képletek másolása.
Sub Szur_Masol_Torol()
Dim usor As Long, WSBev As Worksheet, WSOsz As Worksheet
Dim Bsor As Long, Csor As Long, valasz
valasz = MsgBox("Áttölthetem az adatokat?", vbYesNo + vbQuestion, "Választás")
If valasz = vbNo Then Exit Sub
'lapok védelmének feloldása a makró számára
WSBev.Protect Password:="pw", UserInterfaceOnly:=True
WSOsz.Protect Password:="pw", UserInterfaceOnly:=True
'értékadások
Set WSBev = Sheets("bevitel")
Set WSOsz = Sheets("ÖSSZESÍTÉS")
Bsor = WSOsz.Range("B" & Rows.Count).End(xlUp).Row + 1
usor = WSBev.Range("D2").End(xlDown).Row
'szűrés OK-ra
WSBev.ListObjects("bevitel").Range.AutoFilter Field:=17, Criteria1:="=OK"
'másolás és érték beillesztés
WSBev.Range("D2:T" & usor).Copy
WSOsz.Range("C" & Bsor).PasteSpecial xlPasteValues
'képlet, majd érték beillesztés a B oszlopba
Csor = WSOsz.Range("C" & Rows.Count).End(xlUp).Row
WSOsz.Range("B" & Bsor & ":B" & Csor) = "=B" & Bsor - 1 & "+1"
WSOsz.Columns(2).Copy
WSOsz.Range("B1").PasteSpecial xlPasteValues
'T2:W2 képlete az új sorokba az Összesítés lapon
WSOsz.Range("T2:W2").Copy
WSOsz.Range("T" & Bsor & ":W" & Csor).PasteSpecial xlPasteFormulas
Application.CutCopyMode = False 'kijelölés megszüntetése
With WSOsz.Range("B1").CurrentRegion 'keretezés
.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End With
WSBev.ListObjects("bevitel").Range.AutoFilter Field:=17 'OK-ra szűrés megszüntetése
WSBev.Range("D2:E200,G2:G200,H2:I200,B1:B6").ClearContents 'törlés
'új jelszó a bevitel laphoz
WSBev.Protect Password:="LiliLufi140127", UserInterfaceOnly:=True, _
AllowFiltering:=True, AllowFormattingColumns:=True
End Sub -
Delila_1
veterán
válasz
tgumis
#37532
üzenetére
A lenti sor a MAKRÓ részére feloldja a lap védettségét.
Sheets("Lapneve").Protect Password:="pw", UserInterfaceOnly:=TrueHa előtte nem volt levédve a lap, akkor a beírt jelszóval védetté teszi.
Minek ehhez 3 makró? Eggyel is meg lehet oldani. Arra kell ügyelned, hogy a jelszó a bevitel lapon a makró végén megváltozik (pw-ről LiliLufi140127-re), legközelebb indításkor az újat kell megadnod.
Sub Szur_Masol_Torol()
Dim usor As Long, WSBev As Worksheet, WSOsz As Worksheet
Dim Bsor As Long, Csor As Long
'értékadások
Set WSBev = Sheets("bevitel")
Set WSOsz = Sheets("ÖSSZESÍTÉS")
Bsor = WSOsz.Range("B" & Rows.Count).End(xlUp).Row + 1
WSBev.Protect Password:="pw", UserInterfaceOnly:=True
WSOsz.Protect Password:="pw", UserInterfaceOnly:=True
'szűrés OK-ra
WSBev.ListObjects("bevitel").Range.AutoFilter Field:=17, Criteria1:="=OK"
'másolás és érték beillesztés
usor = WSBev.Range("D2").End(xlDown).Row
WSBev.Range("D2:T" & usor).Copy
WSOsz.Range("C" & Bsor).PasteSpecial xlPasteValues
'képlet, majd érték beillesztés a B oszlopba
Csor = WSOsz.Range("C" & Rows.Count).End(xlUp).Row
WSOsz.Range("B" & Bsor & ":B" & Csor) = "=B" & Bsor - 1 & "+1"
WSOsz.Columns(2).Copy
WSOsz.Range("B1").PasteSpecial xlPasteValues
Application.CutCopyMode = False 'kijelölés megszüntetése
With WSOsz.Range("B1").CurrentRegion 'keretezés
.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End With
WSBev.ListObjects("bevitel").Range.AutoFilter Field:=17 'OK-ra szűrés megszüntetése
WSBev.Range("D2:E200,G2:G200,H2:I200,B1:B6").ClearContents 'törlés
'új jelszó a bevizel laphoz
WSBev.Protect Password:="LiliLufi140127", UserInterfaceOnly:=True, _
AllowFiltering:=True, AllowFormattingColumns:=True
End Sub -
#37530
Delila_1
veterán
dellfanboy
#37529
Delila_1
veterán
válasz
dellfanboy
#37529
üzenetére
Nem elég a formátumot átállítani, a cella értéket is újra le kell enterezni a szerkesztőlécen.
-
-
#37460
Delila_1
veterán
z123456789
#37459
Delila_1
veterán
válasz
z123456789
#37459
üzenetére
Szívesen.
Remélem, most kedvet kaptál egyéb függvények tanulmányozására.
-
#37458
Delila_1
veterán
z123456789
#37457
Delila_1
veterán
válasz
z123456789
#37457
üzenetére
Erre való a SZUMHA függvény.
=SZUMHA(B:B;"benzin";C:C) -
#37438
Delila_1
veterán
macilaci78
#37437
Delila_1
veterán
válasz
macilaci78
#37437
üzenetére
Akkor itt az INDEX-HOL.VAN függvény párosra van szükséged. A másik lap elrendezése olyan, mint a képen levőé? Nem mindegy.
Ha azonos a 2 elrendezés, az A2 képlete
=HAHIBA(INDEX(Munka2!A:B;HOL.VAN(B2;Munka2!B:B;0);1);"")A Munka2 helyett írd be a saját lapod nevét. Ha a lapnév szóközt, vagy számot tartalmaz, akkor aposztrófok közé kell írnod. 'Másik lap neve'!A:B stb.
-
#37435
Delila_1
veterán
macilaci78
#37434
Delila_1
veterán
válasz
macilaci78
#37434
üzenetére
Az Fkeres függvényt alkalmazhatod erre.
-
Delila_1
veterán
A J1:J6 tartományba írtam be a keresendő neveket. Az If WF kezdetű sorban ezt írd át (2 helyen) a saját neveidet tartalmazó területre.
Sub torlesek()
Dim LR As Long, i As Long, WF As WorksheetFunction
Application.ScreenUpdating = False
Set WF = Application.WorksheetFunction
LR = Cells(Rows.Count, 2).End(xlUp).Row
For i = LR To 2 Step -1
If WF.CountIf(Range("J1:J6"), Range("B" & i)) + WF.CountIf(Range("J1:J6"), Range("C" & i)) = 0 Then
Rows(i).EntireRow.Delete Shift:=xlUp
End If
Next i
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
Sub torlesek()
Dim LR As Long, i As Long
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 2).End(xlUp).Row
For i = LR To 2 Step -1
If Range("B" & i) <> "Gipsz Jakab" And Range("C" & i) <> "Gipsz Jakab" And _
Range("B" & i) <> "Rezső Dezső" And Range("C" & i) <> "Rezső Dezső" Then
Rows(i).EntireRow.Delete Shift:=xlUp
End If
Next i
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
válasz
RaZroX
#37346
üzenetére
Nem látszanak a képeken a sor- és oszlopazonosítók, így csak saccolni tudom, mi hol van.
A színezendő cellák eszerint a B3:B14 tartományban vannak, a feltétel az F3:F14-es terület.Kijelölöd a B3:B14-et, és képlettel adod meg a formátumot. A zöldhöz =$F3<>0; piroshoz =$F3=0. A $ jel rögzíti, hogy az F oszlopot értéke alapján történjen a feltételes formázás.
-
Delila_1
veterán
válasz
HollyBoni
#37330
üzenetére
Beállítod az oszlopodat szöveg formátumúra a cellaformázásnál. Az első cellába (A1) beírod: 1-1
Ezt egérrel lehúzva automatikusan nő a kötőjel utáni szám. Mikor elérted az utolsó értéket, alá 2-1-et írsz, és megismétled a fenti lehúzást.Mikor mind kész, a B1 cellába beírod a képletet
=A1&".jpg"Beírás után a cellán állva a jobb alsó sarokban lévő kis fekete négyzeten duplaklikk végig másolja az összes A oszlopban lévő adat mellé a képletet.
Most kijelölöd a B oszlopot, Ctrl+c-vel másolod. Marad a kijelölés, jobb klikk, Irányított beillesztés, Értéket. Az A oszlopot törölheted.
-
#37305
Delila_1
veterán
the radish
#37304
Delila_1
veterán
válasz
the radish
#37304
üzenetére
Nincs mit.
-
#37303
Delila_1
veterán
the radish
#37302
Delila_1
veterán
válasz
the radish
#37302
üzenetére
Range("A1:" & Range("C1").value).Select -
Delila_1
veterán
válasz
Teejay83
#37291
üzenetére
A Munka2 lap A oszlopába felviszed a 30 helységnevet, helyesen.
A példámban a hosszú címek az egyik lap A oszlopában vannak. Ezen a lapon egy üres oszlopba beírod a képletet
=HA(DARABTELI(Munka2!A:A;BAL(A1;SZÖVEG.KERES(",";A1)-1))=0;"Hiba";"Rendben")és lemásolod a többi címed mellé.
-
Delila_1
veterán
Írtam hozzá egy makrót. Nem mondom, hogy villámgyors lesz 40 k adatnál, de gyorsabb, mint "gyalogosan".
Az adatok az A:D oszlopokban vannak, és címsor van az első sorban.
Az A oszlopot átmásolja a G-be, ott megszünteti a duplikációkat. Az összevont B-D adatokat a H oszlopba írja, pontosvesszővel elválasztva.
A körlevélben a G lesz a cím, a H a szöveg.Sub Korlevelhez()
Dim sor As Long, tartomanyA As Range, tartomanyG As Range
Dim CVA As Range, CVG As Range, oszlop As Integer, szoveg As String
Columns("A:A").Copy Range("G1") 'másolás a G oszlopba
'Duplikációk megszüntetése
ActiveSheet.Range("$G:$G").RemoveDuplicates Columns:=1, Header:=xlNo
Set tartomanyA = Range("A2" & ":A" & Range("A2").End(xlDown).Row)
Set tartomanyG = Range("G2" & ":G" & Range("G2").End(xlDown).Row)
'Összevonás a H oszlopba
For Each CVG In tartomanyG
For Each CVA In tartomanyA
If CVA = CVG Then
szoveg = ""
For oszlop = 2 To 4
szoveg = szoveg & Cells(CVA.Row, oszlop) & ";"
Next
Cells(CVG.Row, "H") = Cells(CVG.Row, "H") & szoveg
End If
Next
Next
End Sub -
Delila_1
veterán
Az "ok" szövegek az AF oszlopban vannak. Ez a táblázat első oszlopa? Ha nem akkor az
ActiveSheet.Range(tartomany).AutoFilter Field:=1, Criteria1:="ok"sorban a mezőszámot át kell írnod 1-ről annyira, ahányadik az AF a teljes táblázatban. A feloldásra is érvényes az átírás. Pl. ha AA az első oszlop, akkor a Field:=6
ActiveSheet.Range(tartomany).AutoFilter Field:=1 -
Delila_1
veterán
Valami baj van a fájloddal, mert a makrónak jól kell működnie.
Valószínű, hogy tele van egy halom felesleges adattal, képlettel, esetleg rajz objektumokkal, ha ilyen hatalmas méretű. Ekkora fájl esetén ne várj gyors műveleteket – ez az értékek beillesztésére is vonatkozik.
-
Delila_1
veterán
Az első kérdésedre:
Sub Szures_Torles()
Dim tartomany As String, usor As Long
tartomany = Range("AH1").CurrentRegion.Address
ActiveSheet.Range(tartomany).AutoFilter Field:=1, Criteria1:="ok"
usor = Range("AH" & Rows.Count).End(xlUp).Row
Rows("2:" & usor).Delete Shift:=xlUp
ActiveSheet.Range(tartomany).AutoFilter Field:=1
End SubA másodikhoz nem kell makró. Kijelölöd a területet. Ha nincsenek a területen belül teljes üres sorok, vagy teljes üres oszlopok, akkor a tartomány bármelyik celláján állva a Ctrl+a (all), vagy a Ctrl+t (táblázat) kijelöli az egészet. Másolás (Ctrl+c), jobb klikk, irányított beillesztés, értékeket.
-
Delila_1
veterán
válasz
lacid90
#37253
üzenetére
A szín módosítása nem "esemény" az Excel számára. Egy makróval megoldható. Megváltoztatod a színt, majd duplaklikk a cellán, és megtörténik a másolás.
A fehér háttér igazán fehér, vagy "Nincs kitöltés? A fekete betű fekete, vagy "Automatikus"?
Az idézőjelesekhez írtam a makrót. Ez a duplaklikk hatására a cellával azonos sorba, de 5-tel jobbra másolja a cella tartalmát.Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Interior.ColorIndex <> -4142 Then _
Target.Copy Range(Target.Address).Offset(, 5)
If Target.Font.ColorIndex <> -4105 Then _
Target.Copy Range(Target.Address).Offset(, 5)
End SubA laphoz kell rendelned a makrót, lásd a Téma összefoglalóban.
-
Delila_1
veterán
válasz
föccer
#37252
üzenetére
Makró.
Sub Jeloltek()
Dim CV As Range, ter As Range
Dim U As Integer, L As Integer
Set ter = Range("B1:B" & Range("B1").End(xlDown).Row).SpecialCells(xlCellTypeVisible)
For Each CV In ter
Select Case CV
Case "U", "u": U = U + 1
Case "L", "l", "i", "I": L = L + 1
End Select
Next
Range("L1") = "U: " & U & " db"
Range("L2") = "L: " & L & " db"
End Sub -
Delila_1
veterán
válasz
allein
#37248
üzenetére
Lapfülön (amelyikre beírod az adatokat) jobb klikk, Kód megjelenítése. Beléptél a makró szerkesztőbe, ott is az aktív lapod moduljába. A jobb oldalon kapott nagy üres területre másold be az alábbi pár sort:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count = 1 Then
Sheets("Munka2").Cells(Target.Row, Target.Column) = _
Sheets("Munka2").Cells(Target.Row, Target.Column) + Target
End If
End SubKét helyen szerepel a "Munka2", ezek helyett írd be a saját lapod nevét.
Negatív szám bevitelének hatására csökken a 2. lap azonos cellájának az értéke. -
-
Delila_1
veterán
válasz
Vladek83
#37211
üzenetére
Nem biztos, hogy jól értem. Ki akarod tölteni az üres cellákat az alattuk lévő szövegekkel?
Ha igen, jelöld ki az A9:D28 tartományt. Ctrl+g-re bejön az Ugrás menü. Ott lenyomod az Irányított gombot, majd kiválasztod az Üres cellákat.
Marad a kijelölés. Az aktív cellába írsz egy egyenlőségjelet, majd lenyomod a LE nyilat, Ctrl+Enter beviszi az összes kijelölt cellába a képletet.
Érdemes az egész tartományt újra kijelölni, másolni, majd ugyanoda értékként beilleszteni, hogy a képletek helyén az értékek szerepeljenek.
-
-
#37129
Delila_1
veterán
dajkapeter
#37128
Delila_1
veterán
válasz
dajkapeter
#37128
üzenetére
Erre gondolsz?
Kihagyható a segédoszlop (B) egy tömbfüggvénnyel.
=KICSI(DARABTELI(A1:A9;A1:A9);2)amit Shift + Ctrl + Enterrel viszel be.
-
Delila_1
veterán
Szia Gergő!
Betettem egy új sort, ami rendbe teszi a véletlenek lelkét.
Sub Inditas_Kleb()
Dim kezd As Long, sor As Long
kezd = Range("D" & Rows.Count).End(xlUp).Row + 1
If kezd = 2 Then kezd = 1
Randomize 'ez a sor a lelke
For sor = kezd To kezd + 4
Cells(sor, "D") = Int(Rnd() * 111) + 1
Next
End Sub -
Delila_1
veterán
válasz
PistiSan
#37118
üzenetére
Így igaz!
Próbáld meg egy eseményvezérelt makróval, amit a lappodhoz rendelsz.
Ez a makró duplaklikkre beírja a 2. sor értékeit akkor is, ha túl van az oszlop a Z-n.Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Target = Cells(2, Target.Column * 2 + 1)
Cancel = True
End Sub -
-
Delila_1
veterán
Akkor jön a makró, amit modulba kell bemásolnod.
Sub Atrendez()
Dim Innen As Long, Ide As Long, osszeg As Single
Innen = 2: Ide = 2: osszeg = 0
Cells(1, 10) = Cells(2, 1) & " " & Cells(2, 2)
Do While Cells(Innen, 1) <> ""
If Cells(Innen, 1) & " " & Cells(Innen, 2) = Cells(1, 10) Then
Cells(Ide, 6) = Cells(Innen, 1)
Cells(Ide, 7) = "T"
Cells(Ide, 8) = Cells(Innen, 3)
osszeg = osszeg + Cells(Innen, 3)
Else
Cells(Ide, 6) = Cells(Innen - 1, 2)
Cells(Ide, 7) = "K"
Cells(Ide, 8) = osszeg
Range(Cells(Ide, 6), Cells(Ide, 8)).Font.Bold = True
Cells(1, 10) = Cells(Innen, 1) & " " & Cells(Innen, 2)
Innen = Innen - 1
osszeg = 0
End If
Innen = Innen + 1: Ide = Ide + 1
Loop
Cells(Ide, 6) = Cells(Innen - 1, 2)
Cells(Ide, 7) = "K"
Cells(Ide, 8) = osszeg
Range(Cells(Ide, 6), Cells(Ide, 8)).Font.Bold = True
Cells(1, 10) = Cells(Innen, 1) & " " & Cells(Innen, 2)
End Sub -
-
Delila_1
veterán
Sub Szures_Torles()
Dim usor As Long
'J oszlop szűrése
usor = Range("B" & Rows.Count).End(xlUp).Row '***********
ActiveSheet.Range("$A$1:$K$" & usor).AutoFilter Field:=10, Criteria1:=Array( _
"Befejezett", "Lezárt", "Törölt", "Várakozik"), Operator:=xlFilterValues
Range("A1").CurrentRegion.Offset(1).Delete Shift:=xlUp 'törlés
ActiveSheet.Range("$A$1:$K$" & usor).AutoFilter Field:=10 'szűrő:mind
'B oszlop szűrése
usor = Range("B" & Rows.Count).End(xlUp).Row '***********
ActiveSheet.Range("$A$1:$K$" & usor).AutoFilter Field:=2, Criteria1:=Array("=/=" _
, "A", "B", "C", "D", "E"), Operator:=xlFilterValues
Range("A1").CurrentRegion.Offset(1).Delete Shift:=xlUp 'törlés
ActiveSheet.Range("$A$1:$K$" & usor).AutoFilter Field:=2 'szűrő:mind
End SubAz usor változót olyan oszlopban állítsd be, ahol biztosan minden sorban van adat.
Az A1:K... helyére a szűréshez a saját tartományodat add meg.
Új hozzászólás Aktív témák
Hirdetés
Fferi50
- REFURBISHED és ÚJ - HP USB-C Dock G5 docking station (5TW10AA) - 3x4K felbontás, 120Hz képfrissítés
- ÁRGARANCIA! Épített KomPhone Ryzen 7 5700X 32/64GB RAM RTX 5060Ti 8GB GAMER PC termékbeszámítással
- Microsoft Surface Book 3 - 15 col, i7, 32GB, GTX1660Ti
- Csere-Beszámítás! Xbox One X 1TB Játékkonzol Olvass! Model 1787
- BESZÁMÍTÁS! Asus ROG Flow Z13 + ROG XG RTX 3070 - i9 12900H 16GB DDR5 RAM 1TB SSD + RTX 3070 8GB WIN
Állásajánlatok
Cég: CAMERA-PRO Hungary Kft
Város: Budapest
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest