VBA: Beillesztés, AutoKitöltés, Érvényesítés ellenőrzése

VBA: Beillesztés, AutoKitöltés, Érvényesítés ellenőrzése
2017-05-10T08:49:59+02:00
2017-05-19T21:06:12+02:00
2022-10-15T23:30:30+02:00
nsimon
Sziasztok!

Adott egy 1 munkalapos XLSM fájl (Office 2013-mal szerkesztve), benne kb. 10 oszlop és 500 sor. Több oszlop érvényesítéssel van ellátva (dátum, idő, lista, stb.). Minden más cella pedig zárolt, illetve munkalap- és füzetvédelem van a fájlon. Ezt sok ember használná (nem ugyanazt a fájlt, mindenki a sajátját), és mivel egy adatbázisba szippantódnának a beírt adatok, fontos, hogy a kötött formátumú (érv.) mezők formátuma fix legyen.

Az érvényesítéssel a kívánt oszlopokba írt adatok formátuma/tartalma korlátozható, hibás érték beírása esetén hibaüzenet ugrik fel. Viszont az AutoKitöltés és a Beillesztés simán felülírja a formátumot, illetve az érvényesítési beállításoktól eltérő tartalmat is enged beilleszteni (munkalap védelme esetén az érvényesítési szabályt nem törli, de figyelmen kívül hagyja, nem úgy, mint amikor manuálisan gépeled be a tartalmat - utóbbi esetén működik az érvényesítés). Itt jön képbe a VBA.

Cél (figyelve a munkalap adott változtatásait):
1. AutoKitöltés tiltása (Application.Undo + MsgBox)
2. Beillesztés cseréje Beillesztés értékként-re (Application.Undo + Selection.PasteSpecial)
3. ha a Beillesztés-sel beírt adat nem felel meg a cella/tartomány érvényesítési szabályának, visszavonás (If Not Selection.Validation.Value + Application.Undo + MsgBox)

Próbáltam az 1-2-t egybe venni, a 3-at pedig külön makróként, de ha pl. Beillesztéssel ír felül egy érvényesítéssel ellátott cellát, akkor melyik fut le? A Beillesztést a formátum miatt cserélnie kell, az érvényesítési szabály miatt - ha nem felel meg az érték - pedig vissza kell vonnia.

Ha az Application.EnableEvents sorokat kiveszem (elvileg nem kell, mert nincs esély végtelen ciklusra), akkor is van, hogy menet közben "reset"-eli, azaz kiüríti az Undo listát, nem tudom, miért. Más makró nincs rögzítve, csak ez, a munkalap kódja alatt!

Kód:
(nem működik megfelelően, van, hogy a 3 funkció közül valamelyiket figyelmen kívül hagyja)
(külön figyelve van az Undo lista angol és magyar nyelvű Office használata esetére)

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim UndoStringEN, UndoStringHU As String On Error Resume Next UndoStringHU = Application.CommandBars("Standard").Controls("Visszavonás").List(1) UndoStringEN = Application.CommandBars("Standard").Controls("&Undo").List(1) Application.ScreenUpdating = False Application.EnableEvents = False If UndoStringHU = "AutoKitöltés" Or UndoStringEN = "Auto Fill" Then Application.Undo MsgBox "Az Automatikus kitöltés funkció nem használható," & vbNewLine & _ "helyette a Másolás/Beillesztés-t javasoljuk!" _ , vbCritical, "Automatikus kitöltés" End If If UndoStringHU = "Beillesztés" Or UndoStringEN = "Paste" Then If Not Selection.Validation.Value Then Application.Undo MsgBox "Bizonyos cellákba csak meghatározott formátumú értékek illeszthetők!" & vbNewLine & vbNewLine & _ "Kötött formátumú mezők:" & vbNewLine & _ " - ID: ABC-ABC-12345 (pl. ...)" & vbNewLine & _ " - Dátum: ÉÉÉÉ.HH.NN (pl. 2017.01.01)" & vbNewLine & _ " - Hossz: ÓÓ:PP:MM, azaz ÓRA:PERC:MPERC (pl. 00:00:20)" & vbNewLine & _ " - Jelleg: S, H, K" _ , vbCritical, "Hibás formátum" Else Application.Undo Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End If End If Application.ScreenUpdating = True Application.EnableEvents = True On Error GoTo 0 End Sub

Az érvényesítést figyelő makrónak ez a forrása (külön jól működik):

Private Sub Worksheet_Change(ByVal Target As Range) Dim cella As Range For Each cella In Target If Not cella.Validation.Value Then Application.EnableEvents = False Application.Undo MsgBox "Bizonyos cellákba csak meghatározott formátumú értékek illeszthetők!" & vbNewLine & bNewLine & _ "Kötött formátumú mezők:" & vbNewLine & _ " - ID: ABC-ABC-12345 (pl. ...)" & vbNewLine & _ " - Dátum: ÉÉÉÉ.HH.NN (pl. 2017.01.01)" & vbNewLine & _ " - Hossz: ÓÓ:PP:MM, azaz ÓRA:PERC:MPERC (pl. 00:00:20)" & vbNewLine & _ " - Jelleg: S, H, K" _ , vbCritical, "Hibás formátum" Application.EnableEvents = True Exit Sub End If Next End Sub
Nem vagyok profi VBA-ban, ezért is kérném a segítségeteket, amit előre is nagyon köszönök!

N
Mutasd a teljes hozzászólást!
Szia!

Nagyon köszönöm a segítséged! Így, mivel az Undo lista csak a kézzel bevitt utasításokat kezeli, végül sikerült írni egy olyan kódot, ami csak a legutóbbi kézzel bevitt módosítást ellenőrzi (nincs végtelen ciklus, stb.), és amivel nincs szükség egyéb beállításokra (bill. kombinációk átállítása/tiltása, stb.) sem.
Így mind a cellaformátumok, mind pedig az érvényesítési szabályok védettek maradnak és érvényesülnek.

Működés (magyar és angol nyelvű Excel-ben is működik):
1. Automatikus kitöltés (pl. egérhúzás) esetén -> visszavonás
2. Beillesztés / Irányított beillesztés esetén:
     A. ha a beillesztett értékek nem felelnek meg az adott cellákra beállított Érvényesítési szabályoknak -> visszavonás, majd Exit sub; egyéb esetben -> B.
     B. visszavonás, majd beillesztés értékként

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim UndoStringEN, UndoStringHU As String Dim cella As Range On Error Resume Next UndoStringHU = Application.CommandBars("Standard").Controls("Visszavonás").List(1) UndoStringEN = Application.CommandBars("Standard").Controls("&Undo").List(1) If UndoStringHU = "AutoKitöltés" Or UndoStringEN = "Auto Fill" Then Application.EnableEvents = False Application.Undo MsgBox "Az Automatikus kitöltés nem használható," & vbNewLine & _ "helyette a Másolás-Beillesztést javasoljuk!" _ , vbCritical, "Automatikus kitöltés" Application.EnableEvents = True End If If UndoStringHU = "Beillesztés" Or UndoStringHU = "Irányított beillesztés" Or Left(UndoStringEN, 5) = "Paste" Then Application.EnableEvents = False For Each cella In Selection If Not cella.Validation.Value Then Application.Undo MsgBox "Bizonyos cellákba csak meghatározott formátumú értékek illeszthetők!" & vbNewLine & vbNewLine & _ "Kötött formátumú mezők:" & vbNewLine & _ " - ID: ABC-123 (pl. ...)" & vbNewLine & _ " - Dátum: ÉÉÉÉ.HH.NN (pl. ...)" & vbNewLine & _ " - Hossz: ÓÓ:PP:MM (pl. ...)" _ , vbCritical, "Hibás formátum" Application.EnableEvents = True Exit Sub End If Next Application.Undo Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.EnableEvents = True End If On Error GoTo 0 End Sub
Kiegészítve az alábbi kóddal, mellyel biztosítható, hogy csak XLSM formátumban lehessen rámenteni a fájlra (a Munkafüzet / ThisWorkbook alá rögzítve):
Option Explicit Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim fname As Variant On Error GoTo ErrorHandler Cancel = True fname = Application.GetSaveAsFilename(fileFilter:="Excel Macro-Enabled Workbook (*.xlsm),*.xlsm") If fname = False Then Exit Sub End If Application.EnableEvents = False ThisWorkbook.SaveAs filename:=fname, FileFormat:=52 Application.EnableEvents = True Exit Sub ErrorHandler: Application.EnableEvents = True MsgBox "A mentés közben hiba történt." & vbNewLine & _ "Hibakód: " & Err.Number _ , vbCritical, "Hibaüzenet" End Sub
Mutasd a teljes hozzászólást!

  • Majdnem megtaláltam a megoldást, egy dolgot nem értek csupán:
    A Beillesztések (Ctrl+V)  után miért törlődik/resetelődik az Undo (Visszavonás) lista? (minden művelet eltűnik a listából)

    Az alábbi kód már működne, ha Beillesztés esetén megmaradna az Undo lista utolsó helyén a "Beillesztés", mint utolsó művelet. Így viszont nem működik az Application.Undo parancs, mivel nincs mit visszavonni, és végtelen ciklusba kerül a makró.

    Cél: NE törlődjön az Undo (Visszavonás) lista, tehát mindig láthatók legyenek az utolsó műveletek.

    Jelenlegi kód:
    (az Érvényesítést figyelő kód a fentiek miatt előzi meg a Beillesztés értékként tartalmazó kódot, mert azt hittem, a Selection.PasteSpecial parancs törli valami okán az Undo listát)

    Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim UndoStringEN, UndoStringHU As String Dim cella As Range On Error Resume Next UndoStringHU = Application.CommandBars("Standard").Controls("Visszavonás").List(1) UndoStringEN = Application.CommandBars("Standard").Controls("&Undo").List(1) Application.ScreenUpdating = False If UndoStringHU = "AutoKitöltés" Or UndoStringEN = "Auto Fill" Then Application.Undo MsgBox "Az Automatikus kitöltés funkció nem használható," & vbNewLine & _ "helyette a Másolás/Beillesztés-t javasoljuk!" _ , vbCritical, "Automatikus kitöltés" End If '>>>Az alábbi kód kerül végtelen ciklusba, mert a valami okán törlődő Undo lista miatt nem tudja végrehajtani az Application.Undo parancsot, mert nem talál visszavonható műveletet' If UndoStringHU = "Beillesztés" Or UndoStringEN = "Paste" Then For Each cella In Selection If Not cella.Validation.Value Then Application.EnableEvents = False Application.Undo MsgBox "Bizonyos cellákba csak meghatározott formátumú értékek illeszthetők!" & vbNewLine & vbNewLine & _ "Kötött formátumú mezők:" & vbNewLine & _ " - ID: ABC-ABC-12345 (pl. ...)" & vbNewLine & _ " - Dátum: ÉÉÉÉ.HH.NN (pl. 2017.01.01)" & vbNewLine & _ " - Hossz: ÓÓ:PP:MM, azaz ÓRA:PERC:MPERC (pl. 00:00:20)" & vbNewLine & _ " - Jelleg: S, H, K" _ , vbCritical, "Hibás formátum" Application.EnableEvents = True End If Next End If If UndoStringHU = "Beillesztés" Or UndoStringEN = "Paste" Then Application.Undo Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End If Application.ScreenUpdating = True On Error GoTo 0 End Sub
    Mutasd a teljes hozzászólást!
  • Szia!

    Én az alábbi problémákat látom:

    1.

    For Each cella In Selection
     If Not cella.Validation.Value Then
     Application.EnableEvents = False
     Application.Undo

    Minden egyes cellánál, amelyik megfelel a feltételednek, végrehajtódik az Undo utasítás. Ha több az ilyen cellád, mint az Undo lista hossza, akkor máris elszáll, mikor a lista elfogy szerintem.
    2. Ennek a programrésznek a végén szerintem kellene egy exit sub, hogy ne fusson rá a következő, ugyanolyan feltételeket vizsgáló programrészre.  Illetve az előző részben le kellene ezt is kezelni.

    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia!

    Először is köszönöm a tanácsot! Valahol igazad van, ezzel kapcsolatban két gondolat:

    1. ha az Undo megtörténik, elvileg már nem lehet ilyen cella, mert a Beillesztés visszavonásával az összes ilyen cella "visszavonódik", tehát nem futhat le az Application.Undo parancs (persze ettől még nem szép a kód)

    2. a legjobb megoldás szerintem az alábbi lenne, de mivel a Selection.PasteSpecial után már üres az Undo lista, így ha nem felel meg az érvényesítésnek a visszavont, majd értékként beillesztett adat, már nincs mit visszavonni, így a rossz érték marad a cellában, amit amúgy az érvényesítési szabály nem engedne meg:
    (nem tudom, miért törlődik az Undo lista "magától" - más makró nem fut, csak amit bemásoltam -, ha nem törlődne, az megoldaná a problémát)

    If UndoStringHU = "Beillesztés" Or UndoStringEN = "Paste" Then Application.Undo Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False For Each cella In Selection If Not cella.Validation.Value Then Application.EnableEvents = False Application.Undo MsgBox "Bla-bla-bla", vbCritical, "Hibás formátum" Application.EnableEvents = True Exit sub End If Next End If
    Mutasd a teljes hozzászólást!
  • Szia!

    Tovább vizsgálódva az eseményeken, az alábbiakat tapasztaltam:

    Cél: NE törlődjön az Undo (Visszavonás) lista, tehát mindig láthatók legyenek az utolsó műveletek

    Ez sajnos kivitelezhetetlen, mivel az Application.Undo csak a legutolsó kézzel bevitt művelet visszaállítására képes! Amint ez lefutott, a következő Application.Undo parancs ezt az utolsó műveletet állítja vissza! (csak Redmond a megmondhatója, hogy mi okból kifolyólag :( ), az Undo lista pedig törlődik a makró végrehajtása után.
    (Gyakorlatban a makróban lekérdezhető és furcsa módon lépteti is a List(1)-ben az értéket, DE NEM AZT HAJTJA VÉGRE, ami abban van!)
    Az Undo helpje is azt írja, hogy csak a legutolsó felhasználói adatbevitelt törli.
    Azaz más módot kell találni az ellenőrzött adatbevitelre, ami lehet pl. inputbox aminek a tartalmát a makróval már megfelelő formában írhatod be a cellába, vagy userform, ellátva a bekérendő adatok ellenőrző listájával.
    Az Application.Onkey utasítással letiltható a billentyűzet parancsok végrehajtása, ha a billentyű kombináció mellé "" stringet rendelsz, az kikapcsolja a rendszerparancsot is, de adhatsz hozzá saját eljárást - pl. egy makrót, aminek annyi a dolga, hogy Ctrl+C esetén kikiabál, hogy ez nem használható, majd Application.CutCopyMode=False utasítással kikapcsolja a kijelölést. 
    Sajna ez egérhúzásra nem reagál.

    Üdv.
    Mutasd a teljes hozzászólást!
  • Szia!

    Nagyon köszönöm a segítséged! Így, mivel az Undo lista csak a kézzel bevitt utasításokat kezeli, végül sikerült írni egy olyan kódot, ami csak a legutóbbi kézzel bevitt módosítást ellenőrzi (nincs végtelen ciklus, stb.), és amivel nincs szükség egyéb beállításokra (bill. kombinációk átállítása/tiltása, stb.) sem.
    Így mind a cellaformátumok, mind pedig az érvényesítési szabályok védettek maradnak és érvényesülnek.

    Működés (magyar és angol nyelvű Excel-ben is működik):
    1. Automatikus kitöltés (pl. egérhúzás) esetén -> visszavonás
    2. Beillesztés / Irányított beillesztés esetén:
         A. ha a beillesztett értékek nem felelnek meg az adott cellákra beállított Érvényesítési szabályoknak -> visszavonás, majd Exit sub; egyéb esetben -> B.
         B. visszavonás, majd beillesztés értékként

    Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim UndoStringEN, UndoStringHU As String Dim cella As Range On Error Resume Next UndoStringHU = Application.CommandBars("Standard").Controls("Visszavonás").List(1) UndoStringEN = Application.CommandBars("Standard").Controls("&Undo").List(1) If UndoStringHU = "AutoKitöltés" Or UndoStringEN = "Auto Fill" Then Application.EnableEvents = False Application.Undo MsgBox "Az Automatikus kitöltés nem használható," & vbNewLine & _ "helyette a Másolás-Beillesztést javasoljuk!" _ , vbCritical, "Automatikus kitöltés" Application.EnableEvents = True End If If UndoStringHU = "Beillesztés" Or UndoStringHU = "Irányított beillesztés" Or Left(UndoStringEN, 5) = "Paste" Then Application.EnableEvents = False For Each cella In Selection If Not cella.Validation.Value Then Application.Undo MsgBox "Bizonyos cellákba csak meghatározott formátumú értékek illeszthetők!" & vbNewLine & vbNewLine & _ "Kötött formátumú mezők:" & vbNewLine & _ " - ID: ABC-123 (pl. ...)" & vbNewLine & _ " - Dátum: ÉÉÉÉ.HH.NN (pl. ...)" & vbNewLine & _ " - Hossz: ÓÓ:PP:MM (pl. ...)" _ , vbCritical, "Hibás formátum" Application.EnableEvents = True Exit Sub End If Next Application.Undo Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.EnableEvents = True End If On Error GoTo 0 End Sub
    Kiegészítve az alábbi kóddal, mellyel biztosítható, hogy csak XLSM formátumban lehessen rámenteni a fájlra (a Munkafüzet / ThisWorkbook alá rögzítve):
    Option Explicit Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim fname As Variant On Error GoTo ErrorHandler Cancel = True fname = Application.GetSaveAsFilename(fileFilter:="Excel Macro-Enabled Workbook (*.xlsm),*.xlsm") If fname = False Then Exit Sub End If Application.EnableEvents = False ThisWorkbook.SaveAs filename:=fname, FileFormat:=52 Application.EnableEvents = True Exit Sub ErrorHandler: Application.EnableEvents = True MsgBox "A mentés közben hiba történt." & vbNewLine & _ "Hibakód: " & Err.Number _ , vbCritical, "Hibaüzenet" End Sub
    Mutasd a teljes hozzászólást!
Tetszett amit olvastál? Szeretnél a jövőben is értesülni a hasonló érdekességekről?
abcd