- A sógorokhoz érkezik a kompakt Vivo X200 FE
- Samsung Galaxy S25 - végre van kicsi!
- Garmin Forerunner 970 - fogd a pénzt, és fuss!
- Magisk
- Hivatalos a OnePlus 13 startdátuma
- Mi nincs, grafén akku van: itt a Xiaomi 11T és 11T Pro
- Samsung Galaxy Watch6 Classic - tekerd!
- Milyen okostelefont vegyek?
- Csak semmi szimmetria: flegma dizájnnal készül a Nothing Phone (3)
- Fotók, videók mobillal
-
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
-
Delila_1
veterán
válasz
zsotesz81
#10038
üzenetére
A Sheet1 lap D1 cellájába:
=HA(JOBB(FKERES($A1& "*";Sheet2!$E:$E;1;0);9)="Contr/IBM";"X";"")E1-be: =HA(JOBB(FKERES($A1& "*";Sheet2!$E:$E;1;0);9)="vakia/IBM";"X";"")
Az A oszlopban lévő nevek mellé a D oszlopba tesz X-et, ha a "Contr" szerepel a címében, és az E-be, ha nem.
Nem biztos, hogy jól értem a feladatot, látom, Fire másként értelmezte.
-
Delila_1
veterán
válasz
varikahun
#10028
üzenetére
A 10032-be írt sor elé még egyet tegyél be, amivel együtt így néz majd ki az egész:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 3 Then Exit Sub
If IsEmpty(Target) Then Range(Cells(Target.Row, 1), Cells(Target.Row, 15)).Interior.ColorIndex = xlNone
If Target.Column = 3 And Target = "OK" Then _
Range(Cells(Target.Row, 1), Cells(Target.Row, 15)).Interior.ColorIndex = 6
If Target.Column = 16 And Target = "Worn" Then _
Range(Cells(Target.Row, 1), Cells(Target.Row, 15)).Interior.ColorIndex = 3
End Sub -
Delila_1
veterán
válasz
varikahun
#10024
üzenetére
A lapfülön jobb klikk, Kód megjelenítése.
Bejutottál a VB szerkesztőbe, jobb oldalon kaptál egy üres felületet, ide másold be:Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target = "OK" Then _
Range(Cells(Target.Row, 1), Cells(Target.Row, 15)).Interior.ColorIndex = 6
If Target.Column = 16 And Target = "Worn" Then _
Range(Cells(Target.Row, 1), Cells(Target.Row, 15)).Interior.ColorIndex = 3
End SubEz a C oszlopban megadott OK-ra sárga hátteret ad, a P-be beírt Worn-re pirosat.
A színeket a makróban a 6, ill. a 3 módosításával tudod változtatni. -
Delila_1
veterán
válasz
varikahun
#10017
üzenetére
Jelöld ki a tartományt, amit színezni akarsz. Hívd be a Formátum - Feltételes formázást.
A feljövő ablakban a legördülőben legyen "A képlet értéke", a másodikba írd be: =$C$3="OK", a Formátumnál add meg a megfelelő formátumot.
Ez a 2003-as verzióra vonatkozik, szólj, ha nem ezt használod. -
Delila_1
veterán
válasz
Danecay
#9991
üzenetére
Az E1-től kezdődően bevittem a napokat: 15, 16, ... 31.
Bementem a névadásba, és a napok nevet adtam meg. A hivatkozáshoz ez a kis képlet jött:=OFSZET(Munka1!$E$1;0;0;HOL.VAN(NAP(EOMONTH(MA();0));Munka1!$E:$E;0);1)
Az érvényesítésnél a forráshoz ezt adtam meg: =napok
A gépen a dátumot februárra átírva az érvényesítés 15-től 28-ig, áprilisban 30-ig, májusban 31-ig teszi választhatóvá a napokat.
U.i.:
Ha nincs eomonth függvényed, az Eszközök/Bővítménykezelőben kapcsold be a két Analysis kezdetű bővítményt. -
Delila_1
veterán
válasz
Danecay
#9989
üzenetére
A legördülőnél alkalmazd az érvényesítést. Melyik verziót használod? Más helyen találod meg a 2007-ben és a régebbiekben.
A makróban meg kell adnod az útvonalat és a fájl nevét.
utvonal= "meghajtó:\mappa\almappa\"
FN="MentendőFileNeve"Megadhatod, hogy az aktuális hónap nevével mentsen.
ment=utvonal & FN & "_" & Format(Now, "yyyy.mm") & ".xls"
ActiveWorkbook.SaveAs ment
ActiveWindow.Close 'ezzel bezárod -
-
#9959
Delila_1
veterán
Fire/SOUL/CD
#9958
Delila_1
veterán
válasz
Fire/SOUL/CD
#9958
üzenetére
Törtekkel is hibátlan?
-
Delila_1
veterán
válasz
bozsozso
#9955
üzenetére
Ez egy szükség-megoldás, de attól még az Excel hibája nem szűnt meg.
A ciklus lelassítja a futást, nálam több nagy területről van szó.Próbálgattam, hogy makróból az irányított beillesztéssel történő felszorzást elvégzi, csak éppen a területet cellánként le kell enterezni (!)
Ez persze nem megoldás. Gondoltam, hogy a felszorzás után ugyanarra a területre nyomok egy Paste:=xlValues-t, de az sem javított rajta.A 2007-ből már kiirtották ezt a hibát – tettek helyette egyebet.
-
Delila_1
veterán
Fire
Ez a Te profilod. Meg kellene beszélni Microsoftékkal, hogy egy tartomány (ami szöveg formátumú számokat tartalmaz) makróból csak akkor szorozható fel – alakítható át a művelettel számokká –, ha a tartomány nem tartalmaz törteket. Egész számoknál nincs probléma.
-
Delila_1
veterán
válasz
bozsozso
#9940
üzenetére
Fogalmam sincs. Mostanában jártam én is így. Az eredeti, szöveg formátumú számok tizedes elválasztója pont volt, azokat makróval kicseréltettem vesszőre, ezután jött volna az irányított beillesztés. Ez már nem jött össze.
Addig írtam meg, hogy egy változóba bevettem az 1-et, kijelöltem a nem összefüggő területeket, és egy üzenetet küldtem, hogy illessze be irányítottan, szorzásként.
-
-
Delila_1
veterán
Ezt próbáld meg futtatni:
Sub hiper()
Dim usor As Long, sor As Long, A As String, B As String
Calculate
usor = Range("A6000").End(xlUp).Row
For sor = 1 To usor
Cells(sor, 1).Select
A = Cells(sor, 46)
B = Cells(sor, 1)
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
A, TextToDisplay:=B
Next
End Sub -
Delila_1
veterán
válasz
bozsozso
#9901
üzenetére
Ez az új a Munka2 lapon a B oszlopba írja a Munka1 H oszlopát, és a C-be az I-t.
Sub Összegzés()
Dim usorA As Long, usorT As Long, usor2A As Long
Sheets("Munka1").Select
usorA = Range("A1").End(xlDown).Row 'Alsó sor a Munka1 lapon
'Irányított szűrés egyedi ('A' oszlop) értékekre a T1-be
Range("A1:A" & usorA).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("T1"), Unique:=True
'Alsó sor a T oszlopban
usorT = Range("T1").End(xlDown).Row
'Első üres sor a Munka2 lap A oszlopában
usor2A = Sheets("Munka2").Range("A5000").End(xlUp).Row + 1
'Munka1 T oszlopának másolása a Munka2 A oszlopába
Range("T2:T" & usorT).Copy Sheets("Munka2").Range("A" & usor2A)
Sheets("Munka2").Select 'Szumha képlet a Munka2!B-be
usorA = Range("A1000").End(xlUp).Row
Range("B2:B" & usorA).Select
Selection = "=SUMIF(Munka1!A:A,Munka2!A2,Munka1!B:B)"
Range("C2:C" & usorA) = "=VLOOKUP(A2:A" & usorA & ",Munka1!A:I,8,0)"
Range("D2:D" & usorA) = "=VLOOKUP(A2:A" & usorA & ",Munka1!A:I,9,0)"
Range("A:D").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Cells(2, 1).Select
'Munka1!T oszlop törlése
Sheets("Munka1").Columns(20).Delete
End Sub -
#9897
Delila_1
veterán
Mr.Csizmás
#9896
Delila_1
veterán
válasz
Mr.Csizmás
#9896
üzenetére
Köszi. Ennyire bamba vagyok!
Hiába, április elseje van.¡ǝɾǝslǝ sılıɹdɐ uǝɾlǝ
-
#9895
Delila_1
veterán
Mr.Csizmás
#9894
Delila_1
veterán
válasz
Mr.Csizmás
#9894
üzenetére
Akkor írd le, mi módon jött össze!
Nehogy mind a 90-et, elég 1.
-
#9892
Delila_1
veterán
Mr.Csizmás
#9890
Delila_1
veterán
válasz
Mr.Csizmás
#9890
üzenetére
Tudtommal az élőfejbe nem lehet képfájlt bevinni, csak a Wordben.
-
Delila_1
veterán
Azt hittem, bevitted a sokkal egyszerűbb óra:perc formátumot.
Még mindig jobban járnál vele.Egy üres oszlopban összehozhatnád az A és B, valamint a C és D oszlopok értékeit.
=A1&":"&B1
=C1&":"&D1Ezeket már időértéknek értelmezi az Excel. Értékként beilleszted az új oszlopokat az A-ba és B-be, és már mehet is az egyszerű kivonási képlet ezekre hivatkozva.
-
#9868
Delila_1
veterán
Mr.Csizmás
#9866
Delila_1
veterán
válasz
Mr.Csizmás
#9866
üzenetére
A képet a beillesztés előtt szabd méretre!
Sub Logo()
utvonal = "F:\Temp\"
FN = "filename.gif"
For lap = 1 To Worksheets.Count
Sheets(lap).Select
Cells(3, 1).Select 'Ez az A3-ba teszi, átírhatod
ActiveSheet.Pictures.Insert (utvonal & FN)
Next
End Sub -
#9864
Delila_1
veterán
Mr.Csizmás
#9862
Delila_1
veterán
válasz
Mr.Csizmás
#9862
üzenetére
Próbáltam együttesen kijelölt lapokra bevinni egy képet, de nem tudja.
Marad a Ctrl+c, Ctrl+v az elsőről a másodikra, a többi lapon már elég az F4 billentyű a művelet ismétlésére. -
#9861
Delila_1
veterán
Mr.Csizmás
#9860
Delila_1
veterán
válasz
Mr.Csizmás
#9860
üzenetére
-
#9859
Delila_1
veterán
Mr.Csizmás
#9858
Delila_1
veterán
válasz
Mr.Csizmás
#9858
üzenetére
Na, ennek örülök. Nem a hibáknak, hanem az eredménynek.
Kicsit sok lett volna 50 lapra mindent átmásolni. -
#9857
Delila_1
veterán
Mr.Csizmás
#9856
Delila_1
veterán
válasz
Mr.Csizmás
#9856
üzenetére
Szívesen.
Mi volt a 3 debug? -
#9855
Delila_1
veterán
Mr.Csizmás
#9854
Delila_1
veterán
válasz
Mr.Csizmás
#9854
üzenetére
Van most a füzetedben 1 lap, amiben jó az élőfej.
Indítasz egy makrórögzítést.
A jó lapon állva átkapcsolsz a nyomtatási képbe, ott is a beállításokba, az élőfejbe.
OK. Belépsz (ha van) az élőlábba, OK. Rögzítés vége.Szép hosszú makrót kapsz, amiből csak néhány sort hagysz meg:
With ActiveSheet.PageSetup
.LeftHeader = "Valami1"
.CenterHeader = "Valami2"
.RightHeader = "Valami3"
.LeftFooter = "Valami4"
.CenterFooter = "Valami5"
.RightFooter = "Valami6"
End WithTermészetesen a Valamik helyett a saját adataid lesznek az egyenlőségjel után.
Ha élőláb nincs, a Footer-es sorokat is kihagyhatod.
Most beviszel egy új makrót:Sub Élőfejek()
For lap = 1 To Worksheets.Count
Sheets(lap).Select
'***ide másolod be az előbb rögzített sorokat ***
With ActiveSheet.PageSetup
.LeftHeader = "Valami1"
.CenterHeader = "Valami2"
.RightHeader = "Valami3"
.LeftFooter = "Valami4"
.CenterFooter = "Valami5"
.RightFooter = "Valami6"
End With
'*******************************************************
Next
End SubAhol jelöltem, beviszed a rögzített makró rövidített részét, és futtatod az újat. Minden lapra bemásolja az élőfejet, és ha van, az élőlábat is.
-
#9853
Delila_1
veterán
Mr.Csizmás
#9852
Delila_1
veterán
válasz
Mr.Csizmás
#9852
üzenetére
Másold át a mostani füzetbe a régi lapot, ami az élőfejet tartalmazza, majd erre a lapra az előző tartalom helyett másold be a mostanit.
-
Delila_1
veterán
válasz
bozsozso
#9825
üzenetére
Igazad van, elfelejtettem, hogy a képletek beírásához nem jelöltem ki a B oszlop tartományát. Bemásolom a teljes makrót.
Sub Összegzés()
Dim usorA As Long, usorG As Long, usor2A As Long
Sheets("Munka1").Select
usorA = Range("A1").End(xlDown).Row 'Alsó sor a Munka1 lapon
'Irányított szűrés egyedi ('A' oszlop) értékekre a G1-be
Range("A1:A" & usorA).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("G1"), Unique:=True
'Alsó sor a G oszlopban
usorG = Range("G1").End(xlDown).Row
'Első üres sor a Munka2 lap A oszlopában
usor2A = Sheets("Munka2").Range("A5000").End(xlUp).Row + 1
'Munka1 G oszlopának másolása a Munka2 A oszlopába
Range("G2:G" & usorG).Copy Sheets("Munka2").Range("A" & usor2A)
Sheets("Munka2").Select
'Szumha képlet a Munka2!B-be
Range("B2:B" & Range("A5000").End(xlUp).Row).Select
Selection = "=SUMIF(Munka1!A:A,Munka2!A2,Munka1!B:B)"
Selection.Copy
Selection.PasteSpecial Paste:=xlValues
Cells(2, 1).Select
'Munka1!G törlése
Sheets("Munka1").Columns(7).Delete
End Sub -
Delila_1
veterán
Sub SortWorksheets()
Dim sCount As Integer, i As Integer, j As Integer
Application.ScreenUpdating = False
sCount = Worksheets.Count
If sCount = 1 Then Exit Sub
For i = 1 To sCount - 1
For j = i To sCount
If Worksheets(j).Name < Worksheets(i).Name Then
Worksheets(j).Move Before:=Worksheets(i)
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub -
Delila_1
veterán
válasz
bugizozi
#9813
üzenetére
Valóban, a Te füzeted jó eredményt ad.
Érthetetlen számomra, mert a kódodat bemásoltam egy üres füzetbe, és úgy futtatva kaptam azt az eredményt, aminek a képét az előzőben közöltem. Másik füzetben is kipróbáltam, az eredmény ugyanaz a rossz összegzés.
Előfordul, hogy 1-1 lap hibás az Excelben (pont most volt egy ilyen esetem, hogy hibás volt egy szorzás eredménye), de hogy 2× egymás után 2 különböző füzetben?!
A képlet beírását azért nézd meg a makrómban, nem kell hozzá ciklus, egy lépésben meg lehet oldani, mint ahogy a G oszlop másolását is.
-
Delila_1
veterán
válasz
bozsozso
#9806
üzenetére
Nálam nem a kívánt eredmény jött ki Bugizozi makrójával. Egy kicsit módosítottam rajta, és megjegyzéseket tettem bele.
Sub Összegzés()
Dim usorA As Long, usorG As Long, usor2A As Long
Sheets("Munka1").Select
usorA = Range("A1").End(xlDown).Row 'Alsó sor a Munka1 lapon
'Irányított szűrés egyedi ('A' oszlop) értékekre a G1-be
Range("A1:A" & usorA).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("G1"), Unique:=True
'Alsó sor a G oszlopban
usorG = Range("G1").End(xlDown).Row
'Első üres sor a Munka2 lap A oszlopában
usor2A = Sheets("Munka2").Range("A5000").End(xlUp).Row + 1
'Munka1 G oszlopának másolása a Munka2 A oszlopába
Range("G2:G" & usorG).Copy Sheets("Munka2").Range("A" & usor2A)
Sheets("Munka2").Select
'Szumha képlet a Munka2!B-be
Range("B2:B" & Range("A5000").End(xlUp).Row) = _
"=SUMIF(Munka1!A:A,Munka2!A2,Munka1!B:B)"
Cells(2, 1).Select
'Munka1!G törlése
Sheets("Munka1").Columns(7).Delete
End Sub -
Delila_1
veterán
Rögzíts egy makrót a solver beállításaival, amibe minden feltételt vegyél be.
Legyen annyi üres lapod, ahány változatot szeretnél látni. Az első lapon van a kiinduló táblázat, nálam ez az A1:D5 terület, a célcella D6.Sub solver()
Dim lap As Long, max As Single, változat As Integer
max = 0
változat = 30 'Itt add meg a kért változatok számát
For lap = 1 To változat
Sheets(lap).Select
'Kiinduló változat másolása a következő lapra
If lap < 20 Then
Range("A1:D6").Select 'A saját területedet add meg itt
Selection.Copy Sheets(lap + 1).Cells(1)
End If
'Ide jön a rögzített makró
If Range("D6") > max Then max = Range("D6")
Next
MsgBox max
End Sub -
Delila_1
veterán
Írj be valahova egy 1-est egy üres cellába. Másold (Ctrl+c), jelöld ki a cellákat, amik a bevételeket és kiadásokat tartalmazzák, jobb klikk, Irányított beillesztés, Szorzás.
Ez a művelet számokká alakítja a szövegesen előforduló értékeket, a nem szövegeseknek meg nem árt.
-
Delila_1
veterán
Igen, ez a SZUM függvénynek egy speciális változata. Az első paraméter azt határozza meg, hogy a tartomány adataival mit akarsz kezdeni. A 9 az összegüket, a 2 a darabszámukat számolja össze.
Nézd meg a súgót, ott vannak leírva a lehetséges paraméterek, és az alkalmazásuk. -
#9780
Delila_1
veterán
Fire/SOUL/CD
#9779
Delila_1
veterán
válasz
Fire/SOUL/CD
#9779
üzenetére
Az =részösszeg(9;A:A) megoldja a bővülő tartomány problémáját, csak a részösszeg függvény ne az A oszlopban legyen.
-
Delila_1
veterán
Lehet, hogy igaza van Fire-nek az elírással kapcsolatban, de én úgy értettem a kérdést, hogy az érdekel, hány oszlopban van beállítva valamilyen feltétel szerinti szűrés.
Arra itt a makró hozzá:
Sub SzűrtOszlopok()
Dim oszlop As Integer, sz As Integer
Dim w As Worksheet
Dim FiltOszlop As String
Set w = Worksheets("Munka1")
With w.AutoFilter
FiltOszlop = .Range.Address
For oszlop = 1 To .Filters.Count
If w.AutoFilter.Filters.Item(oszlop).On Then sz = sz + 1
Next
End With
MsgBox sz
End Sub -
#9768
Delila_1
veterán
antikomcsi
#9766
Delila_1
veterán
válasz
antikomcsi
#9766
üzenetére
Másold le a B1 képletét: a cellán állva a jobb alsó sarkában van egy kis fekete négyzet, amit megfogsz az egérrel, és lehúzod addig, amíg szükséges.
Ha az A oszlopban már vannak adataid, akkor lehúzni sem kell, hanem a kis fekete négyzeten egy duplaklikk lemásolja addig, ameddig adatot talál a mellette lévő oszlopban.
-
#9763
Delila_1
veterán
antikomcsi
#9761
Delila_1
veterán
válasz
antikomcsi
#9761
üzenetére
Szívesen.
A verzióra vonatkozó kérdésedet ne nekem tedd fel, mert én a 2007-est sem szeretem, csak az előző változatokat.
Erre majd Fire (ha előkerül) azt mondja, hogy a 2015-ös (!) változatban tanulj ![;]](//cdn.rios.hu/dl/s/v1.gif)
). -
Delila_1
veterán
Valószínű, hogy egy képlet eredménye az A1 értéke.
Az A1, B1, C1, stb. cellákba írd meg a képletet. Az A1 ilyesmi legyen:=Ha(a_kapcsoló_1-et_mutat;ide_jön_a_képlet_azon_része_ami_a_számítást_elvégzi;"")
B1-ben a kritérium a kapcsoló 2-es állása.A következő fázisra váltás előtt az A1-et saját magára másolod értékként (irányított beillesztéssel), vagy ha módodban áll, elrejted a sort – hogy ne kelljen újra összeállítani egy esetleg 30 cm-es képletet.
-
#9756
Delila_1
veterán
antikomcsi
#9755
Delila_1
veterán
válasz
antikomcsi
#9755
üzenetére
=A1 & " " & B1
Látod, tettem közé egy szóközt idézőjelek között.
Szerk.:
A képletedben a nullát nem kell zárójelbe tenni. Így is jó, csak felesleges. -
#9754
Delila_1
veterán
antikomcsi
#9753
Delila_1
veterán
válasz
antikomcsi
#9753
üzenetére
A Munka2 lap A oszlopát szöveg formátumként add meg, ha nem akarod, hogy a 6/1 dátumként jelenjen meg. Az adatok bevitele után jelöld ki, és adj nevet az A oszlopnak, legyen pl. termékek a név.
A Munka1 lapon az A oszlopban kijelölsz annyi cellát, amennyire gondolod, hogy majd feltöltöd, később bővítheted az érvényesítéssel ellátott tartományt. Adatok/ Érvényesítés. A Megengedve legördülőből Lista, a Forráshoz =termékek, OK.
A Munka1!B1-be: =HA(A1>"";FKERES(A1;Munka2!A:B;2;HAMIS);""), ezt másold le a többi cellára a B oszlopban.
-
#9738
Delila_1
veterán
zz13zolika
#9735
Delila_1
veterán
válasz
zz13zolika
#9735
üzenetére
Ha ez az összevont cella mindig azonos méretű, a kép beszúrása után indítasz egy makrórögzítést, megformázod a képet, és a rögzítés befejeztével kiteszel hozzá egy gombot a lapodra.
A többi képet beszúrod, és kattintasz a gombra. -
Delila_1
veterán
Sub Hozzair()
Dim usor As Integer
Workbooks.Open Filename:="F:\TMP\Ebből.xls"
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("Ebbe.xls").Activate
usor = Range("A65536").End(xlUp).Row + 1
Range("A" & usor).Select
Selection.PasteSpecial Paste:=xlPasteFormats
Selection.PasteSpecial Paste:=xlPasteValues
Workbooks("ebből.xls").Close
End Sub -
Delila_1
veterán
Sub Bevisz()
Dim usor As Integer
Sheets("Kezdő_lap").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Másik_lap").Select
usor = Range("A1").End(xlDown).Row + 1
Range("A" & usor).Select
Selection.PasteSpecial Paste:=xlPasteFormats
Selection.PasteSpecial Paste:=xlPasteValues
End Sub -
Delila_1
veterán
válasz
Delila_1
#9721
üzenetére
Eléggé elkapkodtam, sokkal rövidebben is meg lehet írni. Ennél is lehetne, de ahhoz számolnom kellene, amihez most nem fűlik a fogam.
Sub copyz()
Dim usor As Long, tol As Long, ig As Long, hova As String
Sheets("Munka3").Select
usor = Range("E60000").End(xlUp).Row
Select Case usor
Case 13
tol = 8: ig = 38: hova = "A8"
Case 44
tol = 40: ig = 74: hova = "A43"
Case 79
tol = 74: ig = 108: hova = "A78"
Case 114
tol = 109: ig = 143: hova = "A113"
End Select
Range("A" & tol & ":A" & ig).EntireRow.Insert
Sheets("Munka2").Range("A8:G38").Copy
Range(hova).Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
Cells(1).Select
End Sub -
Delila_1
veterán
A csatolt képen a 3-as lapon ott van a cím, és egy 4 soros összegzés, aminek a másolás után lentebb kell kerülnie. A meglévő cím miatt első esetben sem kell a 2. lapról A1-gyel kezdeni a másolást, elég a 8. sortól.
Most megírtam úgy a makrót, hogy az első gombnyomásra beviszi a 2. lap adatait lentebb tolva az összegzést, másodikra ez alá beteszi a következőt, és még 2 esetben a következő kettőt. Vagyis ezzel összesen 4 árajánlatot másolhatsz be egymás alá.
Sub copyz()
Dim usor As Long
Sheets("Munka3").Select
usor = Range("E60000").End(xlUp).Row
Select Case usor
Case 13
Range("A8:A38").EntireRow.Insert
Sheets("Munka2").Range("A8:G38").Copy
Range("A8").Select
Case 44
Range("A40:G74").EntireRow.Insert
Sheets("Munka2").Range("A8:G38").Copy
Range("A43").Select
Case 79
Range("A74:G108").EntireRow.Insert
Sheets("Munka2").Range("A8:G38").Copy
Range("A78").Select
Case 114
Range("A109:G143").EntireRow.Insert
Sheets("Munka2").Range("A8:G38").Copy
Range("A113").Select
End Select
Sheets("Munka2").Range("A8:G38").Copy
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
Cells(1).Select
End Sub -
Delila_1
veterán
Nagy baj, ha 1 gombnyomásra csinálja meg a két másolást? Ha nem, akkor az alábbi makró elintézi.
Sub copyz()
Sheets("Munka3").Select
Range("A8:A73").EntireRow.Insert
Sheets("Munka2").Range("A8:G38").Copy
Range("A8").Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
Range("A8:G38").Copy Range("A43")
Cells(1).Select
End SubVIGYÁZAT! Nem lehetnek összevont cellák a 2-es lap A8:G38 tartományában, mert az értékmásolás nem tekinti azonos méretűnek a másolt-, és a beillesztési területet. Meg lehet másképp is oldani. Pl. a 31-32 sor C:E összegeit tedd a 32. sorba. Nem annyira látványos, mint most, de legalább működik.
A vízszintesen egyesített cellák helyett kiválóan lehet alkalmazni a következő formátumot: kijelölöd az A28:B28 cellákat, Cellaformázás, Igazítás fül, a Vízszintesen listából "A kijelölés közepére". -
#9712
Delila_1
veterán
Fire/SOUL/CD
#9704
Delila_1
veterán
válasz
Fire/SOUL/CD
#9704
üzenetére
Isten éltessen!
Az ünneplés ellenére kiválóan működik a fantáziád.
-
Delila_1
veterán
Tényleg elkerülte a figyelmemet, elnézést.
A Munka1 laphoz rendelt makró:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Then
Dim usor As Long
usor = Sheets("Munka2").Range("A50000").End(xlUp).Row + 1
Rows(Target.Row).Copy
beilleszt usor
End If
End SubÉs most a VB szerkesztőben a füzetedhez nyiss új modult. Insert, Module.
A kapott üres lapra ez jön:Sub beilleszt(usor)
Sheets("Munka2").Select
Rows(usor).Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Munka1").Select
End SubÍgy már értéket illeszt majd be a Munka2-re.
-
![;]](http://cdn.rios.hu/dl/s/v1.gif)
Erre majd Fire (ha előkerül) azt mondja, hogy a 2015-ös (!) változatban tanulj 
Új hozzászólás Aktív témák
Hirdetés
Fferi50- Spórolós topik
- HDD probléma (nem adatmentés)
- A sógorokhoz érkezik a kompakt Vivo X200 FE
- Nintendo Switch 2
- Samsung Galaxy S25 - végre van kicsi!
- Horgász topik
- AMD Ryzen 9 / 7 / 5 9***(X) "Zen 5" (AM5)
- EAFC 25
- Luck Dragon: Asszociációs játék. :)
- Garmin Forerunner 970 - fogd a pénzt, és fuss!
- További aktív témák...
- Microsoft licencek KIVÉTELES ÁRON AZONNAL - UTALÁSSAL IS AUTOMATIKUS KÉZBESÍTÉS - Windows és Office
- Játékkulcsok olcsón: Steam, Uplay, GoG, Origin, Xbox, PS stb.
- ROBUX ÁRON ALUL - VÁSÁROLJ ROBLOX ROBUXOT MÉG MA, ELKÉPESZTŐ KEDVEZMÉNNYEL (Bármilyen platformra)
- Eladó Steam kulcsok kedvező áron!
- Windows, Office licencek kedvező áron, egyenesen a Microsoft-tól - Automata kézbesítés utalással is!
- Újszerű Asus ExpertBook B1 B1500 - 15.6" FullHD IPS - i5-1235U - 16GB - 512GB SSD - Win11 - Garancia
- AKCIÓ! MSI Z690 i7 12700K 32GB DDR4 1TB SSD RX 6800 16GB Phanteks P600S Cooler Master 750W
- LG 27GP95RP - 27" Nano IPS - UHD 4K - 160Hz 1ms - NVIDIA G-Sync - FreeSync Premium PRO - HDR 600
- Xbox Ultimate előfizetések
- Samsung Galaxy A40 64GB, Kártyafüggetlen, 1 Év Garanciával
Állásajánlatok
Cég: CAMERA-PRO Hungary Kft
Város: Budapest
Cég: PC Trade Systems Kft.
Város: Szeged