|
Hallo Zusammen,
ich habe das Problem, dass ich in einer intelligenten Tabelle (als Tabelle formatiert) auf einem geschützten Arbeitsblatt die Zellen per TAB-Taste ansteuere.
Bei der letzten freien Zelle in der Tabellenzeile 1425 wird keine neue Zeile mehr erstellt. Gibt es da eine Beschränkung oder ist in dem VBA-Code etwas nicht richtig?
Modul1:
'##### Aktivierung der TAB-Navigation für ein geschütztes Arbeitsblatt #####
Public Sub mod_Navigation()
Application.ScreenUpdating = False 'Bildschirmflackern verhindern
Const PW As String = "XXX" 'Passwort
Dim WS As Worksheet 'Arbeitsblatt
Dim oLObj As ListObject 'Element der Tabellenauflistung (Listenobjekt auf einem Arbeitsblatt)
Dim oLRow As ListRow 'Alle Zeilen eines Listenobjektes
Dim AnzRow As Long 'Anzahl Zeilen
Dim AnzCol As Long 'Anzahl Spalten
Dim AnzZel As Integer 'Anzahl Zellen
Dim LeZeile As Long 'Letzte Zeile
Dim AdrErZel As String 'Adresse erste Zelle
Dim AdrLeZel As String 'Adresse letzte Zelle
Dim BerLObj As Variant 'Bereich des Listenobjektes
Dim DataSetCC As Variant 'Daten des Listenobjektes
On Error Resume Next
If WS <> "DashBoard" Then
Set WS = ActiveSheet 'aktives Arbeitsblatt auswählen 'oder auch festschreiben -> Bsp: Sheets("Reklamationen")
End If
Set oLObj = WS.ListObjects(1) 'Listenobjekt auswählen
'Set oLRow = oLObj.ListRows.Add 'Listenobjekt um eine neue Zeile ergänzen
AnzRow = oLObj.ListRows.Count 'Zeilenanzahl Listenobjekt (oLObj.DataBodyRange.Rows.Count)
AnzCol = oLObj.ListColumns.Count 'Spaltenanzahl Listenobjekt (oLObj.DataBodyRange.Columns.Count)
AnzZel = oLObj.DataBodyRange.Cells.Count 'Anzahl Datenzellen (oLObj.Range.Cells.Count 'Anzahl Tabellenzellen)
LeZeile = oLObj.DataBodyRange.Cells(AnzZel).Row 'Letzte Tabellenzeile
AdrErZel = oLObj.DataBodyRange.Cells(1).Address 'Adresse der ersten Datenzelle (Address(False, False) für Ausgabe ohne $)
AdrLeZel = oLObj.DataBodyRange.Cells(AnzZel).Address 'Adresse der letzten Datenzelle Address(False, False) für Ausgabe ohne $)
On Error GoTo 0
'Wurde das Listenobjekt (die Tabelle) gefunden?
If oLObj Is Nothing Then
MsgBox "Die Tabelle konnte nicht gefunden werden.", vbExclamation, "Prüfen!"
Exit Sub
End If
'Daten des Listenobjektes (der Tabelle)
If Not oLObj.DataBodyRange Is Nothing Then
DataSetCC = oLObj.DataBodyRange(1, 1).Offset(0, 0).Resize(AnzRow, AnzCol).Value
End If
'MsgBox DataSetCC
'Befindet sich die aktive Zelle im definierten Bereich
Set BerLObj = Intersect(ActiveCell, oLObj.DataBodyRange(1, 1).Offset(0, 0).Resize(AnzRow, AnzCol))
If BerLObj Is Nothing Then
Range(AdrErZel).Select
End If
'MsgBox BerLObj
Application.ScreenUpdating = True 'Hier wieder einschalten, da sonst das Blatt bei TAB-Eingabe nicht automatisch gescrollt wird
With oLObj
If ActiveCell.Address = AdrLeZel Then
ActiveSheet.Unprotect PW
.ListRows.Add
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, _
AllowSorting:=True, AllowFiltering:=True, Password:=PW
'.Range.Cells(.ListRows.Count + 1, 2).Value = .Range.Cells(.ListRows.Count, 2).Value 'Wert aus Vorzeile übernehmen (Alternative: LeZeile = LeZeile // WS.Range("B" & LeZeile) = WS.Range("B" & LeZeile - 1))
.Range.Cells(.ListRows.Count + 1, 2).Select 'Zelle selektieren
Else
ActiveCell.Offset(0, 1).Select
ActiveSheet.EnableSelection = xlUnlockedCells
End If
End With
End Sub
Modul 2
'##### Programmierte SendKeys Funktion (fSendKeys), damit der NumLock nicht versehentlich durch das Makro ausgeschaltet wird #####
'##### von: http://access.mvps.org/access/api/api0046.htm #####
Option Explicit
' Declare Type for API call:
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Maintenance string for PSS usage
End Type
' API declarations:
Private Declare Function GetVersionEx Lib "Kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwflags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetKeyboardState Lib "user32" _
(pbKeyState As Byte) As Long
Private Declare Function SetKeyboardState Lib "user32" _
(lppbKeyState As Byte) As Long
' Constant declarations:
Const VK_NUMLOCK = &H90
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1
Function IsNumLockOn() As Boolean
Dim o As OSVERSIONINFO
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
IsNumLockOn = keys(VK_NUMLOCK)
End Function
Sub ToggleNumLock()
Dim o As OSVERSIONINFO
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then '=====Win95
keys(VK_NUMLOCK) = Abs(Not keys(VK_NUMLOCK))
SetKeyboardState keys(0)
ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then '=====WinNT
'Simulate Key Press
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
'Simulate Key Release
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY _
Or KEYEVENTF_KEYUP, 0
End If
End Sub
Sub mySendKeys(sKeys As String, Optional bWait As Boolean = False)
Dim bNumLockState As Boolean
bNumLockState = IsNumLockOn()
SendKeys sKeys, bWait
If IsNumLockOn() <> bNumLockState Then
ToggleNumLock
End If
End Sub
Function fSendKeys(sKeys As String, Optional bWait As Boolean = False)
' Function to make it callable from macros
mySendKeys sKeys, bWait
End Function
Arbeitsmappe:
Option Explicit
'##### Bei der aktivierten Arbeitsmappe wird die TAB-Navigation eingeschaltet #####
Private Sub Workbook_Activate()
If ActiveSheet.Name <> "DashBoard" Then
Application.OnKey "{TAB}", "mod_Navigation"
End If
End Sub
'##### Bei der deaktivierten Arbeitsmappe wird die TAB-Navigation wieder ausgeschaltet #####
Private Sub Workbook_Deactivate()
Application.OnKey "{TAB}"
End Sub
'##### Bei dem aktivierten Arbeitsblatt wird die TAB-Navigation eingeschaltet #####
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name <> "DashBoard" Then
Application.OnKey "{TAB}", "mod_Navigation"
End If
End Sub
'##### Bei dem deaktivierten Arbeitsblatt wird die TAB-Navigation wieder ausgeschaltet #####
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Application.OnKey "{TAB}"
End Sub
'##### Öffnet bei vorhandenem Auswahlfeld die Auswahl, wenn die Zelle aktiviert wird #####
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim Invalidation As Integer
On Error Resume Next
Invalidation = Target.Validation.Type
On Error GoTo 0
If Sh.Name <> "DashBoard" Then
If Invalidation = xlValidateList Then
If Target.Value = "" Then
fSendKeys "%{Down}" 'Application.SendKeys "%{Down}
End If
End If
End If
End Sub
'##### Verhindert, dass ein neues leeres Tabellenblatt eingefügt werden kann #####
Private Sub Workbook_NewSheet(ByVal Sh As Object)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
Sh.Delete
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Vielen Dank für eine mögliche Unterstützung
Gruß
Michael
|