- Milyen okostelefont vegyek?
- Telekom mobilszolgáltatások
- Huawei Watch 4 Pro - kívül-belül domborít
- One mobilszolgáltatások
- Milyen GPS-t vegyek?
- Fotók, videók mobillal
- Apple Watch
- Bemutatkozott a Poco X7 és X7 Pro
- Csak semmi szimmetria: flegma dizájnnal készül a Nothing Phone (3)
- Google Pixel 9a - a lapos munka
-
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
-
#31357
Delila_1
veterán
Exportlaptop
#31356
Delila_1
veterán
válasz
Exportlaptop
#31356
üzenetére
Örülök, hogy sikerült.
-
Delila_1
veterán
válasz
tzimash
#31353
üzenetére
Szívesen.
Nézd meg a nyilak, és a lakás rajzok megnevezéseit! Azokat kell a saját fájlodban jól megadni.
Tedd modulba a lenti két makrót.
Sub Osszes()
Sheets("Munka1").DrawingObjects.Visible = True
End Sub
Sub EgySem()
Sheets("Munka1").DrawingObjects.Visible = False
Sheets("Munka1").DrawingObjects("Lakás").Visible = True
End Sub -
#31352
Delila_1
veterán
Exportlaptop
#31351
Delila_1
veterán
válasz
Exportlaptop
#31351
üzenetére
Az egyszerűség kedvéért vegyük, hogy azonos füzetben van a két lap. Nevük Egyik és Másik.
Az Egyik lapon az M oszlopig vannak adataid. Itt felveszünk egy segédoszlopot, legyen ez az N.
Címsort feltételezve az N2-be írjuk be az első képletet:=HAHIBA(HOL.VAN(I2;Másik!A:A;0);0)
Ezt végig lemásolod az adataid mellé. Autoszűrőt teszel az első sorba, és szűröd az N oszlopot nullára. A látható sorokat törölheted.
-
#31350
Delila_1
veterán
Exportlaptop
#31347
Delila_1
veterán
válasz
Exportlaptop
#31347
üzenetére
Mi az, hogy másik excel? Másik lap, vagy másik füzet?
-
-
-
Delila_1
veterán
válasz
tgumis
#31316
üzenetére
Azt nem írtad, hogy a G15:G423 adatai melyik lapon vannak. Feltételezem, hogy az adat lapon.
Tehát a nap a kezdőlap B1 cellája, a másolandó adatok az adat lap G15:G423 tartománya, és az összesítő lap megfelelő oszlopába, a 2. sortól kezdve kell bemásolni. Az összesítő lapon a H oszlop a hónap első napja.Sub Osszesites()
Dim oszlop As Integer
oszlop = Sheets("kezdőlap").Range("B1") + 7
Sheets("adat").Range("G15:G423").Copy Sheets("összesítő").Cells(2, oszlop)
End Sub -
Delila_1
veterán
válasz
bteebi
#31313
üzenetére
Az xls kiterjesztésből gondolom, hogy 2007-nél alacsonyabb verziót használsz.
Mikor behívtad a fájlt, a Szerkesztés menüben a Csatolásokat meg tudod nyitni. Kiválasztod a forrásnál az egyik fájlt, amire hivatkozol, majd megnyomod a Váltás gombot, és kitallózod a jelenlegi fájlodat. Így jársz el a többi, behivatkozott fájl esetén is.
-
-
#31276
Delila_1
veterán
hibavissza
#31274
Delila_1
veterán
válasz
hibavissza
#31274
üzenetére
A ThisWorkbook laphoz rendeld a Workbook_Open makrót. Ebben 1 sor legyen:
Sheets("Munka1").Range("AZ5")=Sheets("Munka1").Range("AZ5")+1
Természetesen más lapra és cellára írhatod át. A cella mindig az aktuális megnyitások számát tartalmazza.
-
#31275
Delila_1
veterán
lizakattila
#31273
Delila_1
veterán
válasz
lizakattila
#31273
üzenetére
Írd be egy oszlopba az európai országokat. A feltételes formázásnál FKERES, vagy DARABTELI függvénnyel hivatkozz erre az oszlopra. =darabteli(országnevek_tartománya;A1)>0
-
#31266
Delila_1
veterán
Exportlaptop
#31265
Delila_1
veterán
válasz
Exportlaptop
#31265
üzenetére
Nézd meg az FKERES függvényt, ilyen feladatokra találták ki.
-
Delila_1
veterán
válasz
lumpy92
#31256
üzenetére
Csak teljes cella alsó-, ill. felső indexbe tételéhez írhatsz makrót.
Nem tudsz makrót indítani, mikor 1 cellán belül jelölsz ki pár karaktert, csak ha kiléptél a cellából.Sub felső()
Selection.Font.Superscript = True
End Sub
Sub alsó()
Selection.Font.Subscript = True
End SubHa így megfelel, javaslom, hogy a personalba másold be (lásd Téma összefoglaló), majd a gyorselérési eszköztárra tegyél ki hozzájuk 1-1 ikont.
-
Delila_1
veterán
Ha nem jön össze, add meg, hogy az egyes füzetekből melyik állományokat kell összemásolni.
A
Range("A1").CurrentRegion.Offset(1, 0).Copy WSGy.Range("A" & usor)
sor kijelöli és másolja (címsor nélkül) a megnyitott füzetnek azt a részét, ami az A1 cellától kezdve egybefüggőnek tekinthető. Ezt írhatod be a
Range("A1:A25").Copy WSGy.Range("A" & usor)
sor helyére – ha A1-ben kezdődnek a másolandó tartományaid.
-
Delila_1
veterán
válasz
hallgat
#31233
üzenetére
Készíts egy másolatot a B oszlopról a D-be. Ebben az oszlopban Ismétlődések eltávolítása. Az E oszlopot állítsd szöveg formátumúra. Indulhat a makró.
Sub Ismetlodes()
Dim sorB As Long, sorD As Long, sorE As Long
Dim usorD As Long, usorB As Long
usorD = Range("D" & Rows.Count).End(xlUp).Row
usorB = Range("B" & Rows.Count).End(xlUp).Row
sorE = 2
For sorD = 2 To usorD
For sorB = 2 To usorB
If Cells(sorB, "B") = Cells(sorD, "D") Then Cells(sorE, "E") = Cells(sorE, "E") & "," & Cells(sorB, "A")
Next
Cells(sorE, "E") = Right(Cells(sorE, "E"), Len(Cells(sorE, "E")) - 1)
sorE = sorE + 1
Next
End Sub -
-
Delila_1
veterán
válasz
csferke
#31215
üzenetére
A laphoz rendelt makró:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then _
Target.Offset(0, -1) = Format(Now, "yyyy.mm.dd hh:mm")
End SubEz a teljes B oszlopra vonatkozik, tehát ha az oszlop bármelyik cellájába írsz valamit, az A oszlop azonos sorában megjelenik az aktuális idő.
Meghatározott cella esetén a feltétel
If Target.Address = $B$10" Then _ -
Delila_1
veterán
Nézz el ide.
Keveset kell módosítani benne.
A Range("A1:A25").Copy WSGy.Range("A" & usor) 'másolás sorban az A1:A25 helyett írd be a jelenléti tartomány területét. Mivel ez változik, bőven add meg a sorok számát, hiszen ha többet másol 1-1 füzetből, mint a kitöltött terület, úgyis csak üres cellák kerülnek a gyűjtő füzetedbe, amik a következő jelenléti behívásakor felülíródnak. -
Delila_1
veterán
válasz
bteebi
#31156
üzenetére
Feltettem ide a fájlt.
Az eredeti lapodat átneveztem, az új neve Eredeti. Készítettem róla egy másolatot, a Sheet1-et, ezen dolgoztam.
Tettem a lapra egy feltételes formázást, majd futtattam a makrót. A makró végén az F oszlopba írtam egy ellenőrző képletet. Ha itt minden sorban IGAZ érték van, akkor rendben van a dolog.
-
Delila_1
veterán
-
Delila_1
veterán
válasz
gaben86
#31138
üzenetére
Az M oszlopba írtam be soronként a megjelenítendő képek nevét, kiterjesztés nélkül. Mikor az A:G tartományban rákattintasz egy cellára, ahol az M oszlopban van képnév, a H oszlopban megjelenik a megfelelő kép.
A lapodhoz kell rendelni a makrót. Írd át az útvonalat!
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Kepneve As String, utvonal As String
If Not Intersect(Target, [A:G]) Is Nothing Then
utvonal = "C:\Adott mappa\" 'Ide az igazi útvonalat írd be!
On Error Resume Next
ActiveSheet.Shapes("Kep").Delete
Kepneve = Cells(Target.Row, "M") & ".jpg"
With ActiveSheet.Pictures.Insert(utvonal & Kepneve)
.Name = "Kep"
.Left = Columns(8).Left
.Top = ActiveCell.Top
.Height = 180
End With
On Error Goto 0
End If
End Sub -
#31131
Delila_1
veterán
werszomjas
#31128
Delila_1
veterán
válasz
werszomjas
#31128
üzenetére
Nézz el ide!
-
Delila_1
veterán
válasz
róland
#31066
üzenetére
Feltettem egy füzetet.
Az Adatok lapon oszlopokban, táblázatokban vannak az egyes érvényesítés típusok. A 4-es táblázatnál jeleztem, hogy a G2:G4 tartománynak a _4 nevet adtam, de az első 3-nál is így jártam el. Szükséges a kezdő _ karakter, mert számot önmagában nem lehet névként megadni. Nézd meg a Névkezelőt. A táblázatok tetszés szerint bővíthetőek, ne hagyj üres cellákat bennük.
A Munka1 lapra a nevek után beszúrtam egy oszlopot, ami a névhez tartozó érvényesítés típusát tartalmazza. Az érvényesítést a teljes (C2:E10) területre egyszerre vittem be, az Indirekt függvény alkalmazásával.
-
Delila_1
veterán
válasz
Reinhardt
#31059
üzenetére
A 6 választható adatot a Z1:Z6 tartományba írtam.
A makrót a laphoz kell rendelned. Erről olvashatsz a Téma összefoglalóban.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Application.EnableEvents = False
With Range(Target.Address)
.HorizontalAlignment = xlRight
.Font.ColorIndex = 10
.Offset(1) = Range("Z" & Int(Rnd() * 6) + 1)
.Offset(1).Font.ColorIndex = 5
.Offset(1).HorizontalAlignment = xlLeft
End With
Application.EnableEvents = True
End If
End SubAz A oszlopba beírt adat alá írja a véletlen kiválasztott értéket.
-
-
Delila_1
veterán
válasz
Fferi50
#31032
üzenetére
Igen, ez egy másik felfogása a feladatnak. Megírtam ezt is. A futási idők különbsége csak sok sor esetén mérhető, én mindössze 20 sorral dolgoztam.
Nem tudjuk, hány oszlop van az Eredeti lapon. A makróban az A:K tartományt vettem alapul, amit két helyen kell módosítani, a csillagokkal jelzett sorokban.
Szerk.: az A:K tartományra történő hivatkozást is át lehetne állítani a makróban, de azt már nem írom meg.
Sub Kulcsok()
Dim usor As Long, usor1 As Long, lap As String, sor As Long, lapnev
With Sheets("Eredeti")
.Range("AA:AN").ClearContents
.Range("AA1") = .Range("C1")
.Range("AB1") = .Range("AA1")
.Range("A1:K1").Copy .Range("AD1") '*****
usor = .Range("C" & Rows.Count).End(xlUp).Row
.Range("C1:C" & usor).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range("AA1"), Unique:=True
usor1 = .Range("AA" & Rows.Count).End(xlUp).Row
For sor = 2 To usor1
.Cells(2, "AB") = .Cells(sor, "AA")
'*****
.Range("A1:K" & usor).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("AB1:AB2"), _
CopyToRange:=.Range("AD1:AN1"), Unique:=False
lap = .Range("AB2") & ""
On Error Resume Next
Set lapnev = Sheets(lap)
If Err.Number <> 0 Then
Sheets.Add Before:=Sheets(Sheets.Count)
ActiveSheet.Name = lap
On Error GoTo 0
Else
Sheets(lap).Cells.ClearContents
End If
.Range("AD1").CurrentRegion.Copy Sheets(lap).Range("A1")
Next
End With
Beep
MsgBox "Kész van.", vbInformation
End Sub -
Delila_1
veterán
válasz
Fferi50
#31030
üzenetére
Nem biztos, hogy van minden áfa-kódnak megfelelő lap a füzetben. Azért írtam rá makrót, hogy szükség esetén a hiányzó lapokat létrehozza.
Szerk.:
A makró elején törölni lehetne a második laptól az utolsóig az előző kigyűjtés adatait.A specszűréshez minden lapon kritérium tartományt és címsort kellene előre felvenni.
-
Delila_1
veterán
válasz
Simba86
#31027
üzenetére
Az eredeti, ömlesztett adatokat tartalmazó lapnak az Eredeti nevet adtam. A csillagokkal jelzett sorban írd át a nevét.
A makró végig megy az Eredeti lap sorain. Megnézi, van-e a sorban szereplő ÁFA-kód nevű lap. Ha nincs, létrehozza. Az aktuális sor adatait átmásolja a megfelelő lapra.
Sub Szortirozas()
Dim sor As Long, usor As Long, kod, lapnev
With Sheets("Eredeti") '*****
sor = 2
Do While .Cells(sor, "C") <> ""
kod = .Cells(sor, "C") & ""
On Error Resume Next
Set lapnev = Sheets(kod)
If Err.Number <> 0 Then
Sheets.Add Before:=Sheets(Sheets.Count)
ActiveSheet.Name = kod
.Rows(1).Copy Sheets(kod).Range("A1")
.Rows(sor).Copy Sheets(kod).Range("A2")
On Error GoTo 0
Else
usor = Application.WorksheetFunction.CountA(Sheets(kod).Columns(3)) + 1
.Rows(sor).Copy Sheets(kod).Range("A" & usor)
End If
sor = sor + 1
Loop
End With
Beep
MsgBox "Kész van.", vbInformation
End Sub -
#31016
Delila_1
veterán
thomas50.000
#31015
Delila_1
veterán
válasz
thomas50.000
#31015
üzenetére
Örülök neki, szívesen.
-
#31009
Delila_1
veterán
thomas50.000
#31008
Delila_1
veterán
válasz
thomas50.000
#31008
üzenetére
Valószínűleg jó magasak a sorok, ahova a képeket be akarod illeszteni. A sormagassághoz igazítottam a képek magasságát.
A makró lefutása után az egyik képet állítsd be a kívánt méretre, majd nézd meg, mennyi a magassága.
A 3 With–End With között a.Height = Rows(sor).Height
sorban az egyenlőségjel jobb oldalára ezt az értéket írd be a mostani helyett.
Érdemes még a makró elejére beírni a következő sort:
ActiveSheet.DrawingObjects.Select
ez törli az előző képeket.
-
#31003
Delila_1
veterán
thomas50.000
#31002
Delila_1
veterán
válasz
thomas50.000
#31002
üzenetére
Megoldható, ha a jelzett cellák (B4:B23, L4:L23, AF4:AF23) a képek nevével azonosak, csak a kiterjesztést kell hozzájuk venni. Ezt kell átírnod a csillagozott sorokban, ha nem jpg a kiterjesztés, na meg az útvonalat.
Sub Kepek()
Dim Kepneve As String, utvonal As String, sor As Long
utvonal = "D:\Mappa\Almappa\" '***
For sor = 4 To 23
Kepneve = Cells(sor, "B") & ".jpg" '*****
With ActiveSheet.Pictures.Insert(utvonal & Kepneve)
.Top = Rows(sor).Top
.Height = Rows(sor).Height
.Left = Columns(2).Left + Columns(2).Width - .Width
End With
Kepneve = Cells(sor, "L") & ".jpg" '*****
With ActiveSheet.Pictures.Insert(utvonal & Kepneve)
.Top = Rows(sor).Top
.Height = Rows(sor).Height
.Left = Columns(12).Left + Columns(12).Width - .Width
End With
Kepneve = Cells(sor, "AF") & ".jpg" '*****
With ActiveSheet.Pictures.Insert(utvonal & Kepneve)
.Top = Rows(sor).Top
.Height = Rows(sor).Height
.Left = Columns(32).Left + Columns(32).Width - .Width
End With
Next
End Sub -
#31000
Delila_1
veterán
zsoltzsolt
#30999
Delila_1
veterán
válasz
zsoltzsolt
#30999
üzenetére
Szívesen.
Van rá mód, de ahhoz makró kell.
-
#30998
Delila_1
veterán
zsoltzsolt
#30997
Delila_1
veterán
válasz
zsoltzsolt
#30997
üzenetére
Beírod a bal felsőbe (D5), és húzással másolod jobbra, ill. le.
-
#30996
Delila_1
veterán
zsoltzsolt
#30995
Delila_1
veterán
válasz
zsoltzsolt
#30995
üzenetére
Egyszerű kipróbálni. Készíts pár másolatot a Logopédia lapról – Ctrl billentyűt nyomva tartod, és a lapfület jobbra húzod. Adj nevet a lapoknak.
Írja be mindegyikre 1-1 adatot, a gyűjtő (első) lapra vidd be a képletet.
-
#30994
Delila_1
veterán
zsoltzsolt
#30993
Delila_1
veterán
válasz
zsoltzsolt
#30993
üzenetére
Akkor nagyon egyszerű a dolog.
A lapokat L1, L2, L3, stb-nek neveztem el. A gyűjtő lap D5 cellájának (tónusos dadogás oviba nem járó gyerekeknél) képlete:
=SZUM('L1:L3'!D5)
Az egyes lapok neve lehet a pedagógusok neve is. Az első, és az utolsó lap nevét kell beírni a képletbe.
Az összegző sor képlete maradjon =SZUM(D5:D12). -
#30991
Delila_1
veterán
zsoltzsolt
#30990
Delila_1
veterán
válasz
zsoltzsolt
#30990
üzenetére
Tegyél ki elérhető helyre 1 füzetet a sok közül, hogy lássuk a felépítését. A valódi nevek helyett írj Név1, Név2-t, mert ezek nem publikusak.
-
#30933
Delila_1
veterán
Exportlaptop
#30931
Delila_1
veterán
válasz
Exportlaptop
#30931
üzenetére
Vagy üres sor volt ott, vagy olyan képnév, amit nem talált az adott mappában.
A .Height = Rows(sor).Height
sor végére írd be: *4 -
#30930
Delila_1
veterán
Exportlaptop
#30929
Delila_1
veterán
válasz
Exportlaptop
#30929
üzenetére
Nem sokat kell változtatni.
Sub Kepek()
Dim Kepneve As String, utvonal As String, sor As Long
utvonal = "G:\MUNKA kicsinyitett2\BC adatbazis\Képek összes logos\"
sor = 2
Do While Cells(sor, "H") <> ""
Kepneve = Cells(sor, "H")
With ActiveSheet.Pictures.Insert(utvonal & Kepneve)
.Left = Columns(9).Left
.Top = Rows(sor).Top
.Height = Rows(sor).Height
End With
sor = sor + 1
Loop
End Sub -
#30928
Delila_1
veterán
Exportlaptop
#30927
Delila_1
veterán
válasz
Exportlaptop
#30927
üzenetére
-
#30926
Delila_1
veterán
Exportlaptop
#30925
Delila_1
veterán
válasz
Exportlaptop
#30925
üzenetére
Másold be modulba a lenti makrót (lásd Téma összefoglaló).
Sub Kepek()
Dim Kepneve As String, utvonal As String, sor As Long
utvonal = "D:\Képek\Almappa\" '***
sor = 2
Do While Cells(sor, "I") <> ""
Kepneve = Cells(sor, "I") & ".jpg" '*****
With ActiveSheet.Pictures.Insert(utvonal & Kepneve)
.Left = Columns(8).Left
.Top = Rows(sor).Top
.Height = Rows(sor).Height
End With
sor = sor + 1
Loop
End SubA ***-os soba a saját útvonalad kerüljön.
A *****-os sornál nem kell az & ".jpg", ha a kiterjesztést tartalmazzák a képnevek. Ha más a kiterjesztés, azt írd a jpg helyére. -
#30924
Delila_1
veterán
Exportlaptop
#30923
Delila_1
veterán
válasz
Exportlaptop
#30923
üzenetére
A két füzetet azonos mappába tettem, Az elsőt angol.xlsx, a másodikat (ez az érdekes, mert innen veszi az angol az adatokat) magyar.xlsx néven mentettem. A kérdéses lapok neve is Angol és Magyar.
Az angol.xlsx Angol lapján a B2 képlete:
=INDEX('[magyar.xls]Magyar'!A:C;HOL.VAN(C2;'[magyar.xls]Magyar'!C:C;0);2)Ha nem azonos mappában vannak, akkor az útvonalat is be kell írnod.
-
#30922
Delila_1
veterán
Exportlaptop
#30921
Delila_1
veterán
válasz
Exportlaptop
#30921
üzenetére
Címsort feltételezve az első lap B2 cellája
=INDEX(Magyar!A:C;HOL.VAN(C2;Magyar!C:C;0);2)
Ezt másold le a többi adatod mellé.
-
Delila_1
veterán
-
Delila_1
veterán
A lenti makróban meg kell adnod a keresendő dátumot, és a sor számát, ahol keresel.
Ellenőrzi a bevitt értéket. Két sort megjegyzésbe tettem, azokban megadhatod, hogy nem lehet a dátum éve kisebb, mint az idei, ill. nem lehet kisebb a mai dátumnál.
Sub DatumHelye()
Dim Kelt As String, oszlop, sor As Long
sor = Application.InputBox("Melyik sorban keressünk?", "Sorszám bekérése", , , , , , 1)
Kelt = Application.InputBox("Add meg a dátumot!", "Dátum bekérése", , , , , , 2)
'Ellenőrzés
If Len(Kelt) <> 10 Then GoTo Hiba
If Mid(Kelt, 5, 1) <> "." Then GoTo Hiba
If Mid(Kelt, 8, 1) <> "." Then GoTo Hiba
If Mid(Kelt, 6, 2) > "12" Then GoTo Hiba
If Right(Kelt, 2) > "31" Then GoTo Hiba
If Not IsNumeric(Left(Kelt, 4)) Then GoTo Hiba
If Not IsNumeric(Mid(Kelt, 6, 2)) Then GoTo Hiba
If Not IsNumeric(Right(Kelt, 2)) Then GoTo Hiba
'If Left(Kelt,4)*1 < Year(Date) Then Go To Hiba
'If CDate(Kelt) *1 < Date Then GoTo Hiba
Select Case Mid(Kelt, 6, 2)
Case "02"
If Left(Kelt, 4) / 4 <> Int(Left(Kelt, 4) / 4) And Right(Kelt, 2) > 28 Then GoTo Hiba
Case "04", "06", "09", "11"
If Right(Kelt, 2) > 30 Then GoTo Hiba
End Select
If Left(Kelt, 4) / 4 = Int(Left(Kelt, 4) / 4) And Mid(Kelt, 6, 2) = "02" _
And Right(Kelt, 2) > 29 Then GoTo Hiba
'Keresés
oszlop = Application.Match(CDate(Kelt) * 1, Rows(sor), 0)
If VarType(oszlop) = vbError Then
MsgBox "Nincs " & Kelt & " dátum a " & sor & ". sorban", vbOKOnly + vbInformation
Else
MsgBox "A " & Kelt & " dátum a(z) " & sor & ". sorban, a(z) " & oszlop & ". oszlopban található.", vbOKOnly + vbInformation
End If
Exit Sub
Hiba:
MsgBox "Hibás dátum!", vbOKOnly + vbCritical
End Sub -
Delila_1
veterán
válasz
Carasc0
#30890
üzenetére
A csatolt képeken nem látszik, hova tetted a makrókat, csak az, hogy egymás alá.
Újra leírom: az eseményvezérelt makrót ahhoz a laphoz rendeld, ahol futtatni akarod, a másikat modulba.
Azt látom, hogy az első With-nél átírtad – helyesen – a lap nevét arra, amelyiken éppen futtatod. -
Delila_1
veterán
-
Delila_1
veterán
válasz
Carasc0
#30874
üzenetére
Tartományhoz (pl. C1:C25) használd a Konvertálatlan gombot.
Sub Kever()
Dim sor As Integer, sor1 As Integer
Application.ScreenUpdating = False
With Sheets("BÓNUSZ GENERÁTOROK")
.Range("C1:C50").ClearContents
.Range("A1:A50").Copy Range("C1")
Randomize
.Range("B1:B50") = "=RAND()"
.Range("B1:B50").Copy
.Range("B1").PasteSpecial xlPasteValues
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:= _
.Range("B1:B50"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("B1:C50")
.Header = xlGuess
.Orientation = xlTopToBottom
.Apply
End With
For sor = 1 To 20
If Cells(sor, "C") = "" Then
sor1 = Cells(sor, "C").End(xlDown).Row
Cells(sor1, "C").Copy Cells(sor, "C")
Cells(sor1, "C") = ""
End If
Next
sor1 = Cells(sor, "C").End(xlDown).Row
If Application.WorksheetFunction.CountA(Range("C23:C" & sor1 - 1)) = 0 Then _
Range("C21:C" & sor1 - 1).Delete Shift:=xlUp
sor1 = Cells(Rows.Count, "C").End(xlUp).Row
For sor = sor1 To 21 Step -1
Cells(sor, "C").Insert Shift:=xlDown
Next
sor1 = Cells(Rows.Count, "C").End(xlUp).Row
If sor1 > 50 Then
For sor = 50 To 45 Step -1
If Cells(sor, "C") = "" Then
Cells(sor, "C") = Cells(sor1, "C"): Cells(sor1, "C") = ""
End If
Next
End If
.Range("B1:B50").ClearContents
.Cells(1).Select
End With
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
válasz
Carasc0
#30870
üzenetére
Sub Kever()
Dim sor As Integer
Application.ScreenUpdating = False
With Sheets("BÓNUSZ GENERÁTOROK")
.Range("C1:C50").ClearContents
.Range("A1:A20").Copy Range("C1")
.Range("B1:B20") = "=RAND()"
.Range("B1:B20").Copy
.Range("B1").PasteSpecial xlPasteValues
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:= _
.Range("B1:B20"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With .Sort
.SetRange Range("B1:C20")
.Header = xlGuess
.Orientation = xlTopToBottom
.Apply
End With
.Range("A21:A25").Copy Range("C21")
.Range("B21:B50") = "=Int(Rand() * (50 - 21)) + 21"
.Range("B21:B50").Copy
.Range("B21").PasteSpecial xlPasteValues
.Sort.SortFields.Add Key:= _
.Range("B21:B50"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With .Sort
.SetRange Range("B21:C50")
.Header = xlGuess
.Orientation = xlTopToBottom
.Apply
End With
.Range("B1:B50").ClearContents
.Cells(1).Select
End With
Application.ScreenUpdating = True
End SubHol a söröm?
-
#30861
Delila_1
veterán
the radish
#30860
Delila_1
veterán
válasz
the radish
#30860
üzenetére
Private Sub TextBox1_AfterUpdate()
Application.EnableEvents = False
If Len(TextBox1) <> 11 Or Not IsNumeric(TextBox1) Then
MsgBox "Hibás adószám", vbOKOnly + vbInformation
Exit Sub
Else
TextBox1 = Format(TextBox1,"00000000-0-00")
End If
Application.EnableEvents = True
End Sub
Új hozzászólás Aktív témák
Hirdetés
- Számlás!Steam,EA,Epic és egyébb játékok Pc-re vagy XBox!
- Antivírus szoftverek, VPN
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Adobe Előfizetések - Adobe Creative Cloud All Apps - 12 Hónap - NYÁRI AKCIÓ!
- Azonnali készpénzes GAMER / üzleti notebook felvásárlás személyesen / csomagküldéssel korrekt áron
- 12.000 ft tól elvihető ELITRO Bankmentes , kamatmentes vásárlás .Cooler Master GM2711S Monitor
- Bomba ár! Dell Latitude 7320 - i5-11GEN I 8GB I 256SSD I HDMI I 13,3" FHD I Cam I W11 I Garancia!
- BESZÁMÍTÁS! Gigabyte B760M i5 14600KF 64GB DDR4 512GB SSD RTX 3080 10GB Corsair 4000D Airflow 1000W
- BESZÁMÍTÁS! MSI B450M R7 5700X 16GB DDR4 512GB SSD RTX 3060 12GB Rampage SHIVA Chieftec 600W
Állásajánlatok
Cég: PC Trade Systems Kft.
Város: Szeged
Cég: PC Trade Systems Kft.
Város: Szeged