- Milyen GPS-t vegyek?
- iPhone topik
- A sógorokhoz érkezik a kompakt Vivo X200 FE
- Külföldi SIM-ek itthon
- Samsung Galaxy Watch7 - kötelező kör
- Bemutatkozott a Poco X7 és X7 Pro
- Samsung Galaxy A56 - megbízható középszerűség
- Apple iPhone 16 Pro - rutinvizsga
- Megindult világhódító útjára az új Samsung fülhallgató
- Honor 400 Pro - gép a képben
-
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
-
#41636
Delila_1
veterán
MasterMark
#41633
Delila_1
veterán
válasz
MasterMark
#41633
üzenetére
Félreértettem. Azt hittem, cellán belül nem jó helyről tüntettem el a szóközöket.
Így legalább "megszakértetted", és javítani is tudtad.Sok sikert a további makrózáshoz!
-
#41631
Delila_1
veterán
MasterMark
#41630
Delila_1
veterán
válasz
MasterMark
#41630
üzenetére
"a sortolást nem jó helyről kezdte", mert nem adtad meg.
Autoszűrő, sorszámozás, és formátum a lapokra:
Sub AutSzuro_Sorszam_Formatum()
Dim lap As Integer
For lap = 1 To Sheets.Count
Sheets(1).Range("A:J").Copy
Sheets(lap).Range("A:J").PasteSpecial xlPasteFormats
Sheets(lap).Range("A2").AutoFilter
Sheets(lap).Range("A3" & ":A" & Range("A3").End(xlDown).Row) = "=row()-2"
Next
End Sub -
-
#41626
Delila_1
veterán
MasterMark
#41625
Delila_1
veterán
válasz
MasterMark
#41625
üzenetére
Sub Szortirozas()
Dim usor As Long, sor As Long, lapnev As String
Dim innen As Long, eddig As Long, ide As Long, ujnev As String
'Rendezés album szerint
Sheets("Munka1").Select
usor = Range("A" & Rows.Count).End(xlUp).Row
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add2 Key:=Range("J3:J" & usor), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A1:J" & usor)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Másolás új lapokra
sor = 3
Do While Cells(sor, 10) <> ""
lapnev = Cells(sor, 10)
If Application.WorksheetFunction.CountIf(Columns(10), lapnev) > 1 Then
ujnev = Application.WorksheetFunction.Substitute(lapnev, " ", "")
ujnev = Left(ujnev, 30)
Sheets.Add.Name = ujnev
Sheets("Munka1").Select
Rows("1:2").Copy Sheets(ujnev).Range("A1")
innen = sor
eddig = Application.WorksheetFunction.Match(lapnev, Columns(10), 1)
ide = Sheets(ujnev).Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & innen & ":J" & eddig).Copy Sheets(ujnev).Range("A" & ide)
Sheets(ujnev).Range("A1") = ujnev
sor = eddig + 1
Else
sor = sor + 1
End If
Loop
Sheets("Munka1").Move Before:=Sheets(1)
MsgBox "Kész van az albumonkénti szortírozás", vbInformation, "Információ"
End Sub -
#41624
Delila_1
veterán
MasterMark
#41623
Delila_1
veterán
válasz
MasterMark
#41623
üzenetére
Modulba másold a lenti makrót (lásd a Téma összefoglalóban). A makróban a Munka1 nevet mindenhol írd át a saját lapod nevére.
Sub Szortirozas()
Dim usor As Long, sor As Long, lapnev As String
Dim innen As Long, eddig As Long, ide As Long
'Rendezés album szerint
Sheets("Munka1").Select
usor = Range("A" & Rows.Count).End(xlUp).Row
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add2 Key:=Range("J3:J" & usor), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A1:J" & usor)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Másolás új lapokra
sor = 3
Do While Cells(sor, 10) <> ""
lapnev = Cells(sor, 10)
If Application.WorksheetFunction.CountIf(Columns(10), lapnev) > 1 Then
Sheets.Add.Name = lapnev
Sheets("Munka1").Select
Rows("1:2").Copy Sheets(lapnev).Range("A1")
innen = sor
eddig = Application.WorksheetFunction.Match(lapnev, Columns(10), 1)
ide = Sheets(lapnev).Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & innen & ":J" & eddig).Copy Sheets(lapnev).Range("A" & ide)
Sheets(lapnev).Range("A1") = lapnev
sor = eddig + 1
Else
sor = sor + 1
End If
Loop
Sheets("Munka1").Move Before:=Sheets(1)
MsgBox "Kész van az albumonkénti szortírozás", vbInformation, "Információ"
End Sub -
#41622
Delila_1
veterán
MasterMark
#41621
Delila_1
veterán
válasz
MasterMark
#41621
üzenetére
Az titok, hogy melyik oszlopod tartalmazza a nevet? Az is kell, hogy összesen hány oszlopod van, pl. A-tól
G-ig. -
#41619
Delila_1
veterán
MasterMark
#41618
Delila_1
veterán
válasz
MasterMark
#41618
üzenetére
Ennél azért egy kicsit többet kellene tudnunk.
Egyszer, vagy ritkán kell szétbontani az adatokat, esetleg rendszeresen? Mekkora mennyiségről van szó? Hány féle adat van a szűrendő oszlopban?Első esetben szűröd az oszlopot 1-1 tételre, majd a szűrt állományt másolod (áthelyezed) az új lapra.
A második esetben érdemes makrót írni rá, de ahhoz is legalább annyit kell ismernünk, hogy melyik oszlop szerint kell szűrni, másolni vagy áthelyezni kell az adatokat.
-
Delila_1
veterán
Lehet, hogy lépésenként futtattad, és kiléptél az Application.EnableEvents = True sor végrehajtása előtt. A futás tiltása (False) maradt érvényben.
A VBE felületen Ctrl+g-re megjelenik az Immediate ablak, oda írd be az engedélyező sort, és enterezd le.Átírtam a makrót. A megadott G2:G350 tartomány módosulását figyeli, és az A:C tartományt másolja a 2. lapra, majd a G-t a D-be. Ez utóbbinak nem sok értelme van, ha nullás bevitel esetén másol. Bármilyen G oszlopbeli érték megadásakor történő másoláshoz vedd ki a belső If - End If feltételt. Csakis az If és End If-es sort, a magot ne!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ide As Long
If Not Intersect(Target, [G2:G350]) Is Nothing Then
If Target = 0 Then
Application.EnableEvents = False
ide = Sheets("Munka2").Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & Target.Row & ":C" & Target.Row).Copy Sheets("Munka2").Range("A" & ide)
Range("G" & Target.Row).Copy Sheets("Munka2").Range("D" & ide)
Application.EnableEvents = True
End If
End If
End Sub -
Delila_1
veterán
Az első munkalapodhoz kell rendelned a makrót (a Téma összefoglalóban megtalálod a leírást)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ide As Long
If Target.Column = 7 Then
If Target = 0 Then
Application.EnableEvents = False
ide = Sheets("Munka2").Range("A" & Rows.Count).End(xlUp).Row + 1
Rows(Target.Row).Copy Sheets("Munka2").Range("A" & ide)
Application.EnableEvents = True
End If
End If
End Sub -
Delila_1
veterán
-
Delila_1
veterán
válasz
Sutyi73
#41559
üzenetére
Mivel a
Range("A2:E" & ActiveSheet.UsedRange.Rows.Count).Copy Destination = _ wb.Worksheets("Célmunkalap").Range("A" & wb.Worksheets("Célmunkalap").UsedRange.Rows.Count + 1)sorral már megtörtént a másolás, nincs szükség a
Windows("Órák.xlsm").Activate
Range("A" & wb.Worksheets("Célmunkalap").UsedRange.Rows.Count + 1).Select
ActiveSheet.Pastesorokra. Nem programkódként másoltad ide a makrót, így nem látom, hogy a felső utasítás 1 sorban van-e. A "Destination =" után egy szóközzel alsó kötőjelet tettem be az eredeti mögé.
A mappából megnyitott füzet bezárását így add meg
Workbooks(fileName).Close Falseakkor nem kérdez rá a mentésre.
-
Delila_1
veterán
-
Delila_1
veterán
Táblázattá alakítod a példa szerinti A1:C15 tartományt (Beszúrás, Táblázat, Fejlécek), majd külön-külön nevet adsz az A2:A15, B2:B15, és C2:C15 tartományoknak. A képletekben az új nevekkel hivatkozol rájuk.
Mivel táblázatban vannak, a tartomány bővülésekor a névvel ellátott tartományok automatikusan igazodnak az új sorokhoz.
-
#41411
Delila_1
veterán
huliganboy
#41410
Delila_1
veterán
válasz
huliganboy
#41410
üzenetére
Itt remekül alkalmazhatod a villámkitöltés funkciót.
-
Delila_1
veterán
válasz
bteebi
#41351
üzenetére
Nálam működik a programod.
FFeri arra az esetre gondolt, hogy eseményvezérelt makróba teszed a módosításokat. Átírtam.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
If Target.Column = 3 Then
Application.EnableEvents = False
Sheets("Stat").Cells(Target.Row, "D").ClearContents
If Target.Value = "OK" Or Target.Value = "N/A" Then
Sheets("Stat").Cells(Target.Row, "D").Validation.Delete
Else
With Sheets("Stat").Cells(Target.Row, "D").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Formula1:="Hiba 1,Hiba 2,Hiba 3,Hiba 4"
End With
End If
Set rng = Sheets("Stat").Range("D" & Target.Row & ":E" & Target.Row)
With rng
.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
Application.EnableEvents = True
End If
End Sub -
Delila_1
veterán
Biztosan át tudtad írni.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B2")) Is Nothing And Target.Value = "" Then
Application.EnableEvents = False
Range("C5:E10, C12:E20") = ""
Application.EnableEvents = True
End If
End SubA 11-es sor címszavait meghagytam.
-
Delila_1
veterán
Erre gondolsz?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D2")) Is Nothing And Target.Value = "" Then
Application.EnableEvents = False
Range("C4, E4, F2, H2,h4") = "" ***
Application.EnableEvents = True
End If
End SubEbben a laphoz rendelt makróban a D2 cella tartalmának a törlésekor a csillagokkal jelölt sorban lévő cellák tartalma is törlődik.
Az első sorban a Range("D2")-t átírhatod annak a cellának a címére, ahol törölni akarsz, a ***-gal jelölt sorban a törlendő cellák címét írd be a mostaniak helyett. -
Delila_1
veterán
Fferi válasza is tökéletes, de itt egy másik módszer.
A Munka2 lapon a B1:B9 tartománynak nevet adsz, legyen ez Lista.
A kék képlete, ami nem látszik teljesen
=ÉS(HOL.VAN(A1;Lista;0)>3;HOL.VAN(A1;Lista;0)<7)Ezzel a módszerrel akkor is jó eredményt kapsz, ha a Munka2 lap B oszlopában módosulnak a szövegek.
-
#41280
Delila_1
veterán
PowerBuldog
#41279
Delila_1
veterán
válasz
PowerBuldog
#41279
üzenetére
Talán képletekkel is meg lehet oldani, de nekem egyszerűbbnek tűnik makróval.
Gondolom, az A1:C1 tartományon kívül a többi sorban is vannak adataid, ezért úgy írtam meg a modulba másolandó makrót, hogy menjen végig a sorokon, és a D oszlopba írja annak a cellának a szövegét, amelyikben először találja meg a "Póló" kifejezést. Ha pl. A5-ben és C5-ben is szerepel a szó, az A5 tartalma lesz a D5-ben.
Sub Hol_A_Polo()
Dim oszlop As Integer, sor As Long, usor As Long
usor = Range("A" & Rows.Count).End(xlUp).Row
For sor = 1 To usor
For oszlop = 1 To 3
If InStr(Cells(sor, oszlop), "Póló") > 0 Then
Cells(sor, 4) = Cells(sor, oszlop)
Exit For
End If
Next
Next
End Sub -
Delila_1
veterán
Ezt csak makróval tudod megoldani.
Sub Szinezes()
Range("2:2,5:5,10:10,15:15").Interior.Color = Range("A1").Interior.Color
' Range("A2:L2, A5:L5, A10:L10, A15:L15").Interior.Color = Range("A1").Interior.Color
End SubAz első sor az A1 cella háttérszínével azonosra színezi a 2; 5; 10 és 15. sor celláit.
A második sor, ami most megjegyzésbe van téve, a fenti sorokból csak az A:L tartományt színezi.
Írd át a színezendő területeket a saját igényednek megfelelően, valamint a Range("A1")-et, ha nem az A1 szerint szeretnéd végrehajtani a műveletet.
Töröld a makróból azt a sort, amelyikre nincs szükséged.A makrót kötheted egy billentyű kombinációhoz. Alt+F8-ra bejön a makrókat tartalmazó ablak. Kiválasztod a Szinezes makrót, Egyebek, a Billentyűparancsnál a Ctrl+ -hoz beírsz egy betűt. Ezután erre a kombinációra indul a makró, és színez.
A füzetet makróbarátként kell elmentened.
-
#41212
Delila_1
veterán
pero19910606
#41211
Delila_1
veterán
válasz
pero19910606
#41211
üzenetére
Állj az első sorba, majd a Ctrl+Shift-tel tegyél be autoszűrőt.
A harmadik oszlopban a legördülő nyílra kattintva kiválasztod az eladási helyet, mire az összes többi sor rejtetté válik. A látható tartományt (Ctrl+a) kijelölve másolhatod, és oda illesztheted be, ahova akarod.Másik módszer, hogy kimutatást hozol létre (a tábládban állva a Beszúrás | Kimutatás). A minta szerint töltöd ki a kimutatás mezőit. A G oszlopban beállítottam a cellaformázást ##-##-## -ra.
-
#41187
Delila_1
veterán
dellfanboy
#41186
Delila_1
veterán
válasz
dellfanboy
#41186
üzenetére
Nem Windows, hanem Workbook, majd a következő sorban az A3-ra állás előtt aktívvá kell tenned a lapot is, ahonnan az adatokat másolni akarod.
Sheets("Munka1").SelectMivel nem kell az A3-ra állnod, a Range("A3").Select sor nem is kell.
A következő sorban másolod az eredeti lap A1-hez tartozó teljes tartományát, és a 2. lapra, az A1 cellától kezdődően beilleszted.
Range("A1").CurrentRegion.Copy Sheets(2).Range("A1") -
#41174
Delila_1
veterán
DisRespect
#41173
Delila_1
veterán
válasz
DisRespect
#41173
üzenetére
A laphoz kell rendelnek a makrót (lásd a Téma összefoglalóban).
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B:C")) Is Nothing Then
Application.EnableEvents = False
Range(Target.Address) = "M106 " & Target
Application.EnableEvents = True
End If
End Sub -
#41160
Delila_1
veterán
smallcurrant
#41159
Delila_1
veterán
válasz
smallcurrant
#41159
üzenetére
Véleményezés | Védelem | Tartományszerkesztés engedélyezése.
-
#41123
Delila_1
veterán
the radish
#41122
Delila_1
veterán
válasz
the radish
#41122
üzenetére
Szívesen.
-
#41121
Delila_1
veterán
the radish
#41120
Delila_1
veterán
válasz
the radish
#41120
üzenetére
Kijelölöd az A oszlopot, az Adatok | Szövegből oszlopok menüponttal szétválasztod az adatokat, ahol a határoló jel legyen vessző. Ezután egy üres oszlopban összefűzöd a szükséges cellákat.
=A2 & ", " & B1 & ", " & C1Másolod a képletet tartalmazó oszlopot, majd irányítottan, értékként beilleszted az egy új oszlopba.
Ezzel "csak" az a baj, hogy nem következetesen vannak az adatok az egyes sorokban, nem egységesen mindenhol a 4. adat a járás. Kiss Jenőnél a 2. helyen van. Ezeket egyenként kell javítani. Ha nem lennének ezek az anomáliák, az irányított beillesztés történhetne azonnal az eredeti adatok helyére.
-
#41119
Delila_1
veterán
the radish
#41117
Delila_1
veterán
válasz
the radish
#41117
üzenetére
A B1 cella képlete
=BAL(A1;SZÖVEG.KERES("járás";A1)+4) -
Delila_1
veterán
válasz
logitechh
#41115
üzenetére
Arra van a példa, hogy minden adatot az első üres sorba rögzíts (usor változó). Ha mindig ugyanabba a cellába akarod rögzíteni, akkor a
'Felírás a Munka1 lapra
usor = Sheets("Munka1").Range("A" & Rows.Count).End(xlUp).Row + 1
For oszlop = 1 To 5
Sheets("Munka1").Cells(usor, oszlop) = Controls("ComboBox" & oszlop)
Controls("ComboBox" & oszlop) = ""
Next
Sheets("Munka1").Cells(usor, 6) = TextBox1
TextBox1 = ""részt kell átírnod. Nincs szükség az usor-ra, hanem fixen add meg.
'Felírás a Munka1 lapra
For oszlop = 1 To 5
Sheets("Munka1").Cells(2, oszlop) = Controls("ComboBox" & oszlop)
Controls("ComboBox" & oszlop) = ""
Next
Sheets("Munka1").Cells(2, 6) = TextBox1
TextBox1 = ""Így az adtok a 2. sorba kerülnek, a címsor alá.
Megadhatod a felírást a ComboBox change eseményében is:
Private Sub ComboBox1_Change()
Sheets("Munka1").Cells(2, 1) = ComboBox1 'A2 cella
ComboBox1 = "" 'ComboBox1 üresre állítása
End Sub -
Delila_1
veterán
válasz
logitechh
#41098
üzenetére
Eleve Combobox legyen a formon. Ennek a RowSource paraméterénél megadod a választható adatok helyét, pl. Törzsadatok!A1:A15. Kiválasztáskor a
Private Sub ComboBox1_Change()
Sheets(1).Range("EL5") = ComboBox1
End Submakró beírja az értéket az első lap EL5 cellájába. Nyomógombhoz is rendelheted a makrót a ComboBox helyett.
-
#41090
Delila_1
veterán
Exportlaptop
#41089
Delila_1
veterán
válasz
Exportlaptop
#41089
üzenetére
Szívesen.
-
#41087
Delila_1
veterán
Exportlaptop
#41085
Delila_1
veterán
válasz
Exportlaptop
#41085
üzenetére
SZÖVEG.KERES a barátod.
-
Delila_1
veterán
válasz
sz_abika
#41082
üzenetére
Azonos füzetbe tettem a körte és alma nevű lapokat, amiknek a nevét a Munka1!A1 cellában választom ki, vagy írom be.
Biztosan át tudod alakítani a makrót úgy, hogy a lapok nevét ne a saját füzetben, hanem a ladak.xls-ben keresse, és onnan másoljon.Sub Masolas()
Dim a, lapnev As String
lapnev = Sheets(1).Range("A1")
On Error Resume Next
Set a = Sheets(lapnev) '***
If Err.Number <> 0 Then
MsgBox "Nincs " & lapnev & " nevű lap", vbCritical
Else
Sheets(lapnev).Range("A1:C5").Copy Sheets(1).Range("A2") '*** (sor elején)
End If
On Error GoTo 0
End Sub***-gal jelöltem, hol kell megadnod a másik füzet útvonalát, nevét.
-
Delila_1
veterán
válasz
Fferi50
#41068
üzenetére
Másképp értelmezem. A kitöltött táblázat egy bizonyos sorát kell törölni, majd ehelyett a tábla végére egy utolsó, üres sort beszúrni.
Vegyük, hogy a J12 cella tartalmazza a törlendő sor számát, ott láttam helyet a beírásra.
Sub Beszur_Torol()
Rows(Range("J12")).Delete Shift:=xlUp
Range("A109").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A108:H108").Copy
Range("A109:H109").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End Sub41066, ny.janos: Az összesít képlettel az a baj, hogy a szűrést megszüntetve nem marad meg a sorszámozás.
-
Delila_1
veterán
válasz
logitechh
#41064
üzenetére
Makró arra az esetre, ha a szűrt oszlop az A, a sorszámot pedig a B oszlopba kell írni.
Sub Sorszamozas()
Dim sor As Long, usor As Long, sorszam As Long
usor = Range("A" & Rows.Count).End(xlUp).Row
sorszam = 1
For sor = 2 To usor
If Rows(sor).Hidden = False Then
Range("B" & sor) = sorszam
sorszam = sorszam + 1
End If
Next
End Sub -
Delila_1
veterán
Ha csak lehet, kerüljük a cellák összevonását!
A vízszintes összevonást könnyedén megoldhatjuk. Beírom a szöveget az A1-be, kijelölöm A1:D1 tartományt, aminek a közepén szeretném látni. A Cellaformázás Igazítás fülén a képen látható vízszintes elrendezést választom
Az eredmény
Az egyesítésről olvashatsz még itt is.
-
-
Delila_1
veterán
Beszúrsz egy alakzatot, rajta jobb klikk, Makró-hozzárendelés. Megjelennek a kész makrók, abból kiválasztod, amelyik kell.
Ha a personalba írod a makrót, a gyorselérési eszköztár jobb szélén legördíted a nyilat, További parancsok. A választható parancsok helyénél kiválasztod a Makrókat, ott a megírt makrót, és a Felvétel gombbal felveszed a jobb oldali ablakba, ahol módosíthatod a hozzá rendelt képet, és a megjelenő szöveget.
-
Delila_1
veterán
Rögzítettem egy makrót, ahol egyenként ráálltam a képleteket tartalmazó cellákra a 2. sorban, és leentereztem a szerkesztőlécen. A G2-höz tartozó rész így nézett ki:
Range("G2").Select
ActiveCell.FormulaR1C1 = "=SUMIF(C[5],RC[5],C[-1])"Ezután a makró elején meghatároztam az utolsó sort (usor=...).
A képletek elején lévő ActiveCell-t kicseréltem arra a területre, ahova be kell írni, hogy a 2. soron kívül az összes sorban jelenjen meg a képlet.
Range("G2:G" & usor).FormulaR1C1 = "=SUMIF(C[5],RC[5],C[-1])"és kitöröltem a cellákra állást, pl. a Range("G2").Select-et.
Szerk: mivel mindig új adatokat másolsz be, feltehetően vadiúj füzetbe, a makrót a personalba lenne érdemes beírni, hogy minden füzetben elérhető legyen. Erről is találsz leírást a Téma összefoglalóban. A makróhoz kitehetsz egy ikont a gyorselérési eszköztárra.
Az I oszlop képlete hibás volt, javítottam.
-
Delila_1
veterán
Akkor jön a makrórögzítés.
Írd be a képletet. Rögzítés indítása. A képletet tartalmazó cellára állsz, majd a szerkesztőlécen Enter, rögzítés vége. A képletet tartalmazó cellán állva a jobb alsó sarkában lévő kis fekete négyzeten dupla klikk, ez végig másolja a képletet addig, amíg a mellette lévő oszlopban adatokat talál.
Ez most arról szólt, mikor 1 oszlopban van képlet. Ha több is van, tegyél fel egy (lebutított) fájlt, amiben megjelölöd a képleteket.
-
Delila_1
veterán
-
#40958
Delila_1
veterán
JagdPanther
#40957
Delila_1
veterán
válasz
JagdPanther
#40957
üzenetére
Nem lassít majd a sok sor, mert mindig a 6. sorba viszed be az új adatokat.
Azért egy kicsit egyszerűsítettem a makrókon.Sub Ma()
Sheets("Bevitel").Select
Rows(6).EntireRow.Insert Shift:=xlDown
Range("B6") = Date
Range("E6").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Adat!$F$2:$F$8"
Range("F6").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Adat!$L$2:$L$3"
Range("C7:I7").Copy
Range("C6:I6").PasteSpecial xlPasteFormats
Range("J7").Copy
Range("J6").PasteSpecial Paste:=xlPasteAll
Range("C6").Select
End SubSub Megse()
Rows(6).Delete Shift:=xlUp
End SubSub Hibakiadva()
Cells(6, "H") = Date
End SubSub Hibaelvegezve()
Cells(6, "I") = Date
End Sub -
Delila_1
veterán
Egyszerűbb lenne, ha telepítenéd a naptár vezérlőt, de itt egy ellenőrző makró. A (végül) bevitt dátumot az A1 cellába írja be.
Sub Dat_ellenorzes()
Dim kelt As String
kelt = Application.InputBox("Add meg dátumot", "Dátum bekérése", , , , , , 2)
'Ellenőrzés
'Teljes hossz
If Len(kelt) <> 10 Then GoTo Hiba
'Pontok helye
If Mid(kelt, 3, 1) <> "." Then GoTo Hiba 'nap
If Mid(kelt, 6, 1) <> "." Then GoTo Hiba 'hónap
'Szám-e
If Not IsNumeric(Left(kelt, 2)) Then GoTo Hiba 'nap
If Not IsNumeric(Mid(kelt, 4, 2)) Then GoTo Hiba 'hónap
If Not IsNumeric(Right(kelt, 4)) Then GoTo Hiba 'év
'Számok helyessége
If Left(kelt, 2) > "31" Then GoTo Hiba 'nap
If Mid(kelt, 4, 2) > "12" Then GoTo Hiba 'hónap
Select Case Mid(kelt, 4, 2) 'hónap
Case "02" 'február
If Right(kelt, 4) / 4 <> Int(Right(kelt, 4) / 4) And Left(kelt, 2) > 28 Then GoTo Hiba
Case "04", "06", "09", "11" '30 napos hónapok
If Left(kelt, 2) > 30 Then GoTo Hiba
End Select
If Right(kelt, 4) / 4 = Int(Right(kelt, 4) / 4) And Mid(kelt, 4, 2) = "02" _
And Left(kelt, 2) > 29 Then GoTo Hiba 'szökőév február
Range("A1") = CDate(kelt)
Exit Sub
Hiba:
Dat_ellenorzes
End Sub -
Delila_1
veterán
Az L vegyes értékeiből dátumot, ill. pontot hoz létre az M oszlopban:
Dim usor As Long
usor = Range("L" & Rows.Count).End(xlUp).Row
With Range("M2:M" & usor)
.FormulaR1C1 = "=IFERROR(DATEVALUE(MID(RC[-1],3,10)),""."")"
.Copy
.PasteSpecial xlPasteValues
.NumberFormat = "m/d/yyyy"
End With
Új hozzászólás Aktív témák
Hirdetés
- Milyen GPS-t vegyek?
- NVIDIA GeForce RTX 5080 / 5090 (GB203 / 202)
- Windows 11
- Vírusirtó topic
- iPhone topik
- AMD Ryzen 9 / 7 / 5 9***(X) "Zen 5" (AM5)
- Azonnali informatikai kérdések órája
- Nintendo Switch 2
- Telekom otthoni szolgáltatások (TV, internet, telefon)
- Milyen autót vegyek?
- További aktív témák...
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.
- Gyermek PC játékok
- Sea of Thieves Premium Edition és Egyéb Játékkulcsok.
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Felújított laptopok Számlával, garanciával! Ingyen Foxpost!
- GYÁRI TÖLTŐK DELL LENOVO HP FUJITSU TOSHIBA Macbook---------- Budapest,/MPL/Foxpost
- Bomba ár! HP ZBook Studio G5 - i9-9980H I 32GB I 1TSSD I Nvidia I 15,6" FHD I Cam I W11 I Gar
- Laptop felvásárlás , egy darab, több darab, új , használt ! Korrekt áron !
- Crucial 240GB SSD eladó
Állásajánlatok
Cég: Promenade Publishing House Kft.
Város: Budapest
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest