- iPhone topik
- Xiaomi 14T Pro - teljes a család?
- Motorola Edge 40 - jó bőr
- Egy szenzor, két zoomkamera: újraírta a Huawei a mobilfotózás történetét
- Google Pixel 9 Pro XL - hét szűk esztendő
- Google Pixel topik
- Megérkezett a Google Pixel 7 és 7 Pro
- Honor Magic7 Pro - kifinomult, költséges képalkotás
- Poco M3 - felújított állomás
- Térerő gondok, tapasztalatok
-
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
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.
-
-
lappy
őstag
válasz
lacid90
#35775
üzenetére
Nyiss egy füzetet, és csak egy lapot hagyj benne. Alt+F11-re bejön a VBE. Nyitsd ki bal oldalon a füzetedet (+ jelnél). Insert/Module. Jobb oldalon kaptál egy üres modullapot. Oda másold be a kódot!
Lépj vissza az Excelbe, mentés másként, valami.xla (bővítmény).
Zárd be és nyitsd meg újra az Excelt. Az Eszközök/Bővítménykezelőben szerepelni fog a valami, jelöld be.Ezután már a függvényeid között is megtalálod, a Felhasználói, és a Mind kategóriákban.
-
Mutt
senior tag
válasz
lacid90
#15981
üzenetére
Hello,
A megadott adatok alapján faragtam a kódon és felraktam egy mintát ide.
A kód pedig így néz ki, továbbra is egy Backup munkalapra menti a módosításokat:
Option Explicit
Public vEredeti 'ez tartalmazza majd az eredeti értéket
Private Sub Worksheet_Activate()
'ha megnyitjuk a lapot akkor egyből jegyezzük meg hogy mi van a B1 cellában
vEredeti = ActiveSheet.Range("B1").Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Const vBackupSheet As String = "Backup"
Dim vLastRow
Dim wsNew As Worksheet
Dim wsCurrent As String
'ha a C1 cella értéke 0 vagy üres
If ActiveSheet.Range("C1").Value = 0 Or ActiveSheet.Range("C1").Value = "" Then
'megnézzük hogy létezik-e a munkalap ahova a korábbi értékeket mentjük
On Error Resume Next
Set wsNew = Worksheets(vBackupSheet)
If Err Then
wsCurrent = ActiveSheet.Name
Set wsNew = Sheets.Add
With wsNew
.Name = vBackupSheet
'ha akarod akkor a lenti sorral rejtetté tudod tenni a lapot
'.Visible = xlSheetHidden
End With
Sheets(wsCurrent).Activate
End If
'megnézzük hogy melyik az utolsó sor a backup munkalapon
vLastRow = Application.WorksheetFunction.CountA(ThisWorkbook.Sheets(vBackupSheet).Range("A:A")) + 1
'ha már nincs a munkalapon több üres sor akkor leállunk a naplózással
If vLastRow > ThisWorkbook.Sheets(vBackupSheet).Rows.Count Then
MsgBox "Nincs több hely a mentésre!", vbOKOnly, "Hiba"
Exit Sub
End If
'adunk egy fejlécet a backup munkalapnak
If vLastRow = 1 Then
ThisWorkbook.Sheets(vBackupSheet).Range("A" & vLastRow) = "Eredeti érték"
vLastRow = vLastRow + 1
End If
'mentjük az eredeti értéket és hogy melyik cellából jött
ThisWorkbook.Sheets(vBackupSheet).Range("A" & vLastRow) = vEredeti
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'ha az A1 cellára lépünk, csak akkor jegyezzük meg a B1 értékét
If Target.Address = "$A$1" Then
vEredeti = ActiveSheet.Range("B1").Value
End If
End SubAmi pluszt beletetettem, hogy a munkalap megnyitásakor már megjegyzi az eredeti értéket, mivel előfordulhat az az esete hogy éppen az A1 cellában állsz és az értéket felülírod mozgás nélkül.
Fontos, hogy a makró csak akkor műkődik ha az A1 cellába mindig visszamész, vagyis ha mindig a szerkesztősorban változtatod a cella értékét akkor nem fog műkődni mert a cellából nem mész el.üdv.
-
Mutt
senior tag
válasz
lacid90
#15975
üzenetére
Hello,
Hogyan lehet egy cella értékét eltárolni úgy, hogy lenullázás után is valahol megmaradjon az értéke.
A munkalap SelectionChange és Change eseményére kell tenned makrókat.
A Change csak akkor fut le amikor a cella értéke már megváltozott, itt a korábbi értéket már nem látod, ezért érdemes amikor a cellát kiválasztod (ez a SelctionChange) megjegyezni a korábbi értéket.Feltöltöttem egy lehetséges megoldást ide
http://www.filedropper.com/15975backupPróbáltam több logikát is beépíteni, amit a kommentek alapján akár te is ki tudsz ütni.
1. Nyit egy új munkalapot (Backup névvel) és oda menti az eredeti értéket, vmint a módosult cella címét.
2. Csak akkor ment, ha a cella tényleg megváltozik, ha ugyanaz kerül be akkor nem ment. Ha erre nem tartasz igényt akkor töröld ezt a részt:
vEredeti <> Target.Resize(1, 1).Value
3. Nem ment akkor sem, ha üres cella volt eredetileg. Ha ez sem kell, akkor ezt vedd ki:
And vEredeti <> ""
4. Ha egy cellában egy képlet van, akkor a képletet másolja és nem az eredményét. Ha ezzel nem akarsz élni, akkor a SelectionChange-ben csak ez legyen:
vEredeti = Target.Resize(1, 1).Value
bFuggvenytTartalmaz = FalseHátrányok:
1. Érvényesítést (Data Validation-t) használó celláknál nem megy.
2. Több cella egyidejű módosításakor csak a tartomány bal felső sarkában lévő cellára megy (ennek kikerülésére a második lapon próbáltam egy másik megoldást is csinálni, de az sem 100%-os).
3. Nem teszteltem túl, ezért lehet benne hiba.Itt a kód, ha a fájl már nem lenne letölthető:
Option Explicit
Public vEredeti 'ez tartalmazza majd az eredeti értéket
Public bFuggvenytTartalmaz As Boolean 'ez akkor lehet hasznos ha függvényből jön a cella érték
Private Sub Worksheet_Change(ByVal Target As Range)
Const vBackupSheet As String = "Backup"
Dim vLastRow
Dim wsNew As Worksheet
Dim wsCurrent As String
'ha az eredeti és az új érték eltér és eredetileg nem üres volt a cella akkor módosítunk
If vEredeti <> Target.Resize(1, 1).Value And vEredeti <> "" Then
'megnézzük hogy létezik-e a munkalap ahova a korábbi értékeket mentjük
On Error Resume Next
Set wsNew = Worksheets(vBackupSheet)
If Err Then
wsCurrent = ActiveSheet.Name
Set wsNew = Sheets.Add
With wsNew
.Name = vBackupSheet
'ha akarod akkor a lenti sorral rejtetté tudod tenni a lapot
'.Visible = xlSheetHidden
End With
Sheets(wsCurrent).Activate
End If
'megnézzük hogy melyik az utolsó sor a backup munkalapon (a B oszlopban mindig lesz érték)
vLastRow = Application.WorksheetFunction.CountA(ThisWorkbook.Sheets(vBackupSheet).Range("B:B")) + 1
'ha már nincs a munkalapon több üres sor akkor leállunk a naplózással
If vLastRow > ThisWorkbook.Sheets(vBackupSheet).Rows.Count Then
MsgBox "Nincs több hely a mentésre!", vbOKOnly, "Hiba"
Exit Sub
End If
'adunk egy fejlécet a backup munkalapnak
If vLastRow = 1 Then
ThisWorkbook.Sheets(vBackupSheet).Range("A" & vLastRow) = "Eredeti érték"
ThisWorkbook.Sheets(vBackupSheet).Range("B" & vLastRow) = "Módosított cella"
vLastRow = vLastRow + 1
End If
'mentjük az eredeti értéket és hogy melyik cellából jött
If bFuggvenytTartalmaz Then
ThisWorkbook.Sheets(vBackupSheet).Range("A" & vLastRow) = "'" & vEredeti
Else
ThisWorkbook.Sheets(vBackupSheet).Range("A" & vLastRow) = vEredeti
End If
ThisWorkbook.Sheets(vBackupSheet).Range("B" & vLastRow) = Target.Resize(1, 1).Address
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'ha függvényt tartalmaz a cella, akkor a függvényt másoljuk, különben az értékét
If Range(Target.Address).Resize(1, 1).HasFormula Then
vEredeti = Target.Resize(1, 1).Formula
bFuggvenytTartalmaz = True
Else
vEredeti = Target.Resize(1, 1).Value
bFuggvenytTartalmaz = False
End If
End Subüdv.
-
Excelbarat
tag
válasz
lacid90
#15975
üzenetére
Makróval oldható meg
bár ebben nem vagyok otthon, de valami olyasmi a megoldás hogy ha módosul a cella akkor azt kigyűjti (értsd átmásolja ) egy másik cellába v. munkalapra. (célszerűbb munkalapra gyűjteni és lekódolni) esetleg egy gomb hozzáadása ami megcsinálja, (de ha minden igaz létezik olyan hogyha módosul a cella akkor lefut x makró gondolom könnyű szerrel megírható)poffsoft és Delila_1 biztosan tud segíteni ebben, sztem csak idő kérdése és elő is jönnek egy megoldással
valami ilyesmi:
Sub nullázó()
Sheets("munkalapnév").Select
If (Cells("A5").Value = "0") Then
Range("A5").Select
Selection.Copy
Range("F5").Select
ActiveSheet.Paste
End If
End Sub -
Delila_1
veterán
-
Delila_1
veterán
válasz
lacid90
#14457
üzenetére
Nem értem, mit is akarsz végrehajtani. A két gombhoz rendelt makróval a SumColor makrót hívod meg, de a szinek makrót akarod indítani.
A gombhoz rendelt makrókban értéket adsz két változónak (szin, le). Ezeket a pillanatnyi értékeket át kell adnod a meghívott, szinek makrónak.
Így csináld:
Private Sub CommandButton1_Click() 'v.zöld 35
szin = 35: le = 1
szinek szin, le 'a változók megadásával hívod meg a szinek makrót
End Sub
Sub szinek(szin, le)
Application.ScreenUpdating = False 'a képernyőfrissités kikapcsolása (makró gyorsítás)
Dim CV As Range, usor As Long
oszl = ActiveCell.Column
ActiveCell.Interior.ColorIndex = szin
...
...
Application.ScreenUpdating = True
ActiveCell.Offset(le).Activate
End Sub -
Delila_1
veterán
válasz
lacid90
#14446
üzenetére
Szívesen.
Ha megint leáll valami hasonló hiba miatt, a VB szerkesztőben állva adj egy Ctrl+G-t, mire jobb oldalon lent kapsz egy kis ablakot. Oda másold be a Application.EnableEvents = True sort. és adj neki Entert. Újra fut majd a makród.
A 14395-re:
A változókat publikusként add meg a makró fölött, akkor mindegyik makród eléri.
Public változó As Integer
Public tömb(10,2) -
Delila_1
veterán
válasz
lacid90
#14444
üzenetére
Egy fölöttébb fárasztó pihenésem volt...
Egy laphoz rendelt, eseményvezérelt makró megoldja.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [A:A]) Is Nothing Then
Application.EnableEvents = False
Cells(Target.Row, "A") = Round(Target.Value / 5, 0) * 5
Application.EnableEvents = True
End If
End SubEz az A oszlopba bevitt értékeket figyeli árgus szemekkel {If Not Intersect(Target, [A:A]) Is Nothing Then}, és a bevitel sorába írja a kerekített értéket {Cells(Target.Row, "A") = Round(Target.Value / 5, 0) * 5}.
-
Overtaker
csendes tag
válasz
lacid90
#14439
üzenetére
Ez egy jó kérdés, és szerintem nem megoldható. Cella formázással csak 1000-re vagy a többszörösére lehet "kerekíteni" (egy szóközzel a formátumkód végén, de ugye, a szám ilyenkor nem változik, csak a megjelenése), 5-ösre szerintem nem lehet. Kénytelen leszel egy másik cellába képletet írni és azzal kiszámolni.
-
#14377
Fire/SOUL/CD
félisten
lacid90
#14375
válasz
lacid90
#14375
üzenetére
Nem, csak 2 Excel-nek kell megnyitva lennie, nem 3-nak. Nem tudom milyen OS-t használsz, de Vista/W7 esetén (előtte zárj be minden megnyitott Excel-t) WIN gomb +R/beír excel és enter, majd megismétled még1x.
(XP-nél erre nem emléxem és most nem is tudom kipróbálni sajnos) -
#14374
Fire/SOUL/CD
félisten
lacid90
#14373
válasz
lacid90
#14373
üzenetére
Ez már megint más programozást igényel, mint amit korábban kérdeztél...
Az Excel-t 2 példányban kell megnyitni, így az egyik ezen, a másik azon a monitoron lesz látható (nyilván most a videokari beállításaira nem térek ki), és ez eddig rendben is van, ez az egyszerűbb része a dolognak. Viszont a 2 alkalmazás közti kommunikáció megint más tészta és oda Windows API függvények bevonása is szükséges, amit kezdő, az excel-el, makróval stb csak most ismerkedő versenyzőnek igen kemény avagy kivitelezhetetlen feladat.
(OS és Office függő, ezen belül x86 avagy x64 sem mindegy, más és más deklarációt igényel a makróban az API függvények, és az sem árt, ha tudja valaki, hogy mik is azok az API függvények és hogy abból van több száz/ezer...)Ezt elkerülendő egy kerülőmegoldást tudok elképzelni, azaz 2 példányban van megnyitva az Excel, az egyikben egy makró elmenti a munkafüzetet, ha bármilyen módosítást észlel, a másik excel meg meghatározott időközönként ebből a munkafüzetből olvassa be az adatokat, pl másodpercenként.
-
#14348
Fire/SOUL/CD
félisten
lacid90
#14347
válasz
lacid90
#14347
üzenetére
Megnyitod Excel-el mindkét munkafüzetet. Amelyikből másolod az adatokat, annak a munkalapnak a Change eseményébe kell írni a kódot.
Egy egyszerű példa: Adott 2 munkafüzet, Munkafüzet1 és Munkafüzet2 néven. Mindkettő meg van nyitva az Excel-el és a Munkafüzet1, Munka1 lapjának A1 cellájának módosításakor (és csak az A1 cella módosításakor) átmásolja az A1 cellát, a Munkafüzet2, Munka1 lapjának A1 cellájába.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
Workbooks("Munkafüzet2.xlsm").Sheets("Munka1").Range("A1") = Range("A1")
End If
End Sub -
Delila_1
veterán
-
#14336
Fire/SOUL/CD
félisten
lacid90
#14334
-
#14332
Fire/SOUL/CD
félisten
lacid90
#14331
válasz
lacid90
#14331
üzenetére
Valószínűleg a munkafüzetben található makró(k) dolgoziz/dolgoznak olyan cellával, amelyeket levédtél. Ha ez a szitu, akkor ezt a "logikai buborékot" csak Te tudod feloldani, azaz át kell írni a makróban azokat a sorokat, amelyek védett cellával dolgoznak úgy, hogy a művelet idejére makróval feloldod, majd a művelet befejeztével makróval újra engedélyezed a védelmet/zárolást.
-
Delila_1
veterán
válasz
lacid90
#14275
üzenetére
Az A:F oszlopok hátterét vizsgálja a makró. Ha a teljes sort akarod ellenőriztetni, a Range("A" & sor & ":F" & sor) helyett ezt írd be: Range(Cells(sor, 1), Cells(sor, Columns.Count)) .
Sub Szines()
Dim CV As Object, sor As Integer
sor = ActiveCell.Row
For Each CV In Range("A" & sor & ":F" & sor)
If CV.Interior.ColorIndex <> -4142 Then
MsgBox "Van színes hátterű cella"
Exit Sub
End If
Next
MsgBox "Nincs színes hátterű cella"
End Sub -
#14270
Fire/SOUL/CD
félisten
lacid90
#14269
válasz
lacid90
#14269
üzenetére
Ha úgy érted, hogy az újonnan beszúrt sor és B oszlop metszéspontjába kell a csillag, akkor
Private Sub CommandButton1_Click()
ActiveCell.Offset(1).EntireRow.Insert
Range("B" & ActiveCell.Row + 1) = "*"
End SubHa az aktuális cella sorának és B oszlopának metszéspontjába kell a csillag, akkor töröld ki a makróból a + 1-et.
Új hozzászólás Aktív témák
Hirdetés
Fferi50
- Adobe Előfizetések - Adobe Creative Cloud All Apps - 12 Hónap - NYÁRI AKCIÓ!
- Kaspersky, McAfee, Norton, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Vírusirtó, Antivirus, VPN kulcsok
- Sea of Thieves Premium Edition és Egyéb Játékkulcsok.
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- AKCIÓ! GIGABYTE AORUS MASTER RX 6800 XT 16GB videokártya garanciával hibátlan működéssel
- Így lesz a Logitech MX Keys magyar billentyűzetes
- Csere-Beszámítás! Asus Rog Strix RTX 3070Ti 8GB GDDR6X Videokártya!
- Telefon felvásárlás!! Samsung Galaxy A20e/Samsung Galaxy A40/Samsung Galaxy A04s/Samsung Galaxy A03s
- ÁRGARANCIA!Épített KomPhone i3 10105F 16/32/64GB RAM RX 6600 8GB GAMER PC termékbeszámítással
Állásajánlatok
Cég: CAMERA-PRO Hungary Kft
Város: Budapest
Cég: PC Trade Systems Kft.
Város: Szeged