AW: Daten in den Zellen?
17.06.2015 21:12:42
Sepp
Hallo Hans,
klar, das geht auch.
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
If Sh.Name = "Hidden Cells" Then
If SheetExist(Sh.Cells(1, 1).Text) Then
If Target <> "" Then
If Target.Column = 1 Then
Cancel = True
Application.Goto Sheets(Sh.Cells(1, 1).Text).Rows(Target), True
ElseIf Target.Column = 3 Then
Cancel = True
Application.Goto Sheets(Sh.Cells(1, 1).Text).Columns(Target & ":" & Target), True
End If
End If
End If
End If
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub hiddenRowsAndColumns()
Dim rng As Range
Dim vntRows() As Variant, vntCols() As Variant
Dim lngLast As Long, lngR As Long, lngC As Long
Dim objSH As Worksheet
Dim strName As String
On Error GoTo ErrExit
With ActiveSheet
If .Name <> "Hidden Cells" Then
If .UsedRange.Count > .UsedRange.SpecialCells(xlCellTypeVisible).Count And .UsedRange.Count > 1 Then
strName = .Name
lngLast = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
For Each rng In .Range(.Cells(1, 1), .Cells(lngLast, 1))
If .Rows(rng.Row).Hidden Then
Redim Preserve vntRows(lngR)
vntRows(lngR) = rng.Row
lngR = lngR + 1
End If
Next
lngLast = Application.Max(2, .Cells(1, .Columns.Count).End(xlToLeft).Column)
For Each rng In .Range(.Cells(1, 1), .Cells(1, lngLast))
If .Columns(rng.Column).Hidden Then
Redim Preserve vntCols(lngC)
vntCols(lngC) = Split(rng.EntireColumn.Address(0, 0), ":")(0)
lngC = lngC + 1
End If
Next
Else
MsgBox "Keine versteckten Spalten oder Zeilen in diesem Tabellenblatt!", vbInformation
Exit Sub
End If
End If
End With
If lngR > 0 Or lngC > 0 Then
If SheetExist("Hidden Cells") Then
Set objSH = Sheets("Hidden Cells")
Else
Set objSH = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
objSH.Name = "Hidden Cells"
End If
With objSH
.Cells.Clear
.Cells(1, 1) = strName
If lngR > 0 Then
.Cells(3, 1) = "Hidden Rows"
.Cells(4, 1).Resize(lngR, 1) = Application.Transpose(vntRows)
End If
If lngC > 0 Then
.Cells(3, 3) = "Hidden Columns"
.Cells(4, 3).Resize(lngC, 1) = Application.Transpose(vntCols)
End If
.Columns.AutoFit
.Activate
End With
End If
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'hiddenRowsAndColumns'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - hiddenRowsAndColumns"
.Clear
End If
End With
On Error GoTo 0
Set objSH = Nothing
End Sub
Public Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Gruß Sepp