MS EXCEL Tipps & Tricks © 2003 Klaus-Martin Buss

© Klaus-Martin Buss www.kmbuss.de
Diese Seite ist Teil eines Framesets. Sollte links kein Navigationsmenü angezeigt werden, bitte hier klicken ...

VBA-Codes

Automatische eMail	Speichern unter Namen in A1	Filterfunktion trotz Blattschutz
Inhalt A1 als Blattname übernehmen	Öffnen nach best. Datum nur mit PW	Makrostart nach Tabellenaufruf
Code nach Verlassen Zelle A1	Passwortabfrage vor Makrostart	Übernahme A1 als Kopfzeile links
Makro nach Bestätigung MsgBox	Datensicherung	Datum & Uhrzeit in A1 stempeln
Sprung in letzte Zelle eines Bereichs	Nach Öffnen Wert in A1 erhöhen	Wert in A1 durch 100 teilen
Nach Filter sichtbare Zeilen löschen	Suche nach Daten über InputBox	Listet und markiert Verknüpfungen
Prüft, ob Tabellenblatt vorhanden	Fügt gezielt neue Zeilen ein	Datum & Uhrzeit letzte Speicherung
Speichern bei Schliesen / Beenden	Letzten Wert Spalte A in B1 einlesen	Liest verfügbare Schriftarten aus
Abfrage, ob Blattschutz eingeschaltet	Automatische Breite und Höhe	Aktive Zelle gelb unterlegen
Dateipfad & -name in Fusszeile	Tabellenblätter alphabetisch sortieren	Verknüpfungen zu Workbooks finden
Setzt Zelle auf Grundwert zurück	Öffnet CD-ROM-Laufwerk	Schliesst CD-ROM-Laufwerk
Liest Dateinamen aus Verzeichnis B1	Delete-Taste bei Formel deaktivieren	Spalten trotz Blattschutz ausblenden
Optimale Spaltenbreite einstellen	Nach Eingabe Passwort-Blattschutz	Druck bestimmter Seite
Symbolleiste auf Standard setzen	Datum & Uhrzeit Dateierstellung	Liest den Druckbereich aus
Datum Zelländerung im Kommentar	Löscht Zeilenumbruch in aktiver Zelle	Schaltet Computer vollständig ab
MsgBox mit Speicherdatum	Zellwert im Kommentar anzeigen	Tabellenblattnamen auslesen
Schliessen ohne Speichern	Persönlichen Assistenten rufen	AutoKorrektur-Liste lesen / schreiben
"Glätten" eines Bereichs	In A1 angegebene Anwendung starten	Datei bei jedem Beenden speichern
"Del"-Taste bei Formel deaktivieren	Cursor (Mauszeiger) positionieren	UserForm nicht über "X" schliessen
Zellkommentare nur mit Passwort	Spaltenbreite nach Zellmarkierung	Spaltenbreite nach Spaltenmarkierung
Zugriffsprotokoll	Zeile ausblenden, wenn Zelle leer ist	Zeilen ausblenden, wenn Zellwert = 0
AutoFilter zurücksetzen

Automatischer Versand einer Excel-Arbeitsmappe an mehrere e-Mail-Empfänger
Sub Mail()
ActiveWorkbook.SendMail "webmaster@kmbuss.de", "Neue Datei xlstipps", False
ActiveWorkbook.SendMail "klausmartinbuss@aol.com", "Neue Datei xlstipps", False
End Sub

T O P

Speichern einer Arbeitsmappe unter einem in Zelle A1 festgelegten Namen
Sub DaSi ()
ActiveWorkbook.SaveAs Filename:="C:\Ordnername\" & ActiveSheet.Range("A1")
End Sub

T O P

Filterfunktion auch bei eingeschaltetem Blattschutz
Sub FilternAuchBeiBlattschutz()
ActiveSheet.Protect userinterfaceonly:=True
ActiveSheet.EnableAutoFilter = True
End Sub

T O P

Spalten trotz eingeschaltetem Blattschutz ausblenden
Sub Spalten_trotz_Blattschutz_ausblenden()
ActiveSheet.Protect userinterfaceonly:=True
Columns("C:C").Select
Selection.EntireColumn.Hidden = True
End Sub

T O P

Inhalt von Zelle A1 als Tabellennamen übernehmen
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Not Intersect(Target, Range("a1")) Is Nothing Then
Range("a2").Select
End If
If Target = Range("A1") Then ActiveSheet.Name = Target
End Sub

T O P

Arbeitsmappe nach dem 14.05.2003 nur mit Passwort öffnen (Modul "Diese Arbeitsmappe")
Private Sub Workbook_Open()
Application.DisplayAlerts = False
Heute = Now
Verfalldatum = #5/14/2003# 'Hier Verfalldatum im Format MM/TT/JJJJ eintragen

If Verfalldatum < Heute Then
Dim passwort As String
    passwort = InputBox("Die Testphase ist abgelaufen," & Chr(13) & Chr(13) & "  bitte geben Sie Ihre Registrierungs-Nr.:", "Testphase abgelaufen, Reg.Nr. erforderlich")
    If passwort <> "36" Then
    MsgBox "     Das Kennwort ist ungültig," & Chr(13) & Chr(13) & "der Vorgang wird abgebrochen !"
    ThisWorkbook.Close
End If
MsgBox ("Registrierung erfolgreich")
Application.DisplayAlerts = True
End If
End Sub

T O P

Makro nach Aufrufen des Tabellenblattes starten ( In Tabellenblatt, nicht DieseArbeitsmappe, nicht Modul)
Private Sub Worksheet_Activate()
Makroname 'Makroname ohne Anführungsstriche
End Sub

T O P

MsgBox mit Datum der letzten Sicherung beim Öffnen einer Arbeitsmappe einblenden
Private Sub Workbook_Open()
MsgBox ActiveWorkbook.BuiltinDocumentProperties(12).Name & ActiveWorkbook.BuiltinDocumentProperties(12)
End Sub

T O P

Aktion nach Verlassen der ausgefüllten Zelle "A1" ausführen
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Not Intersect(Target, Range("a1")) Is Nothing Then
"MAKROCODE"
End If
End Sub

T O P

Passwortabfrage vor Makrostart
Sub Passwortabfrage()
Dim passwort As String
passwort = InputBox("Passwort:", "Passworteingabe")
If passwort <> "xyz" Then Exit Sub
Else
"MAKROCODE"
End Sub

T O P

Übernahme des Textes aus Zelle A1 in Tabelle 1 als Kopfzeile links
(Mitte = CenterHeader, rechts = RightHeader)
Private Sub Worksheet_Change(ByVal Target As Range)
If (Target = Range("A1")) Then
Worksheets("Tabelle1").PageSetup.LeftHeader = Range("A1")
End If
End Sub

T O P

Optimale Spaltenbreite einstellen
Sub Optimale_Breite()
Columns("A:IV").Select
Range(Selection, Selection.End(xlToRight)).Select
Cells.EntireColumn.AutoFit
End Sub

T O P

Makro erst nach Bestätigung der MsgBox ausführen
Sub MsgBox_bestätigen()
If MsgBox("Text1" & Chr(13) & "Text2" & Chr(13) & "Text3" & Chr(13) &
Chr(13) & "Text4" & Chr(13) & Chr(13), vbYesNo, "Titel der MsgBox") = vbNo Then
Exit Sub
Else
"MAKROCODE"
End If
End Sub

T O P

Datensicherung
Sub Datensicherung()
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:="C:\Datensicherung.xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    Application.DisplayAlerts = True
End Sub

T O P

Aktuelles Datum und Uhrzeit mit Doppelklick in eine Zelle "stempeln"
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
ActiveCell = Date & ", " & Time
End Sub

T O P

Tabellenblatt nach Eingabe mit Passwort "abc" schützen (In Tabellenblatt)
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
ActiveSheet.Protect "abc"
End Sub

T O P

Sprung in die letzte Zelle eines Bereichs
Sub LetzteZelle()
Rows.SpecialCells(xlCellTypeLastCell).Rows.Activate
End Sub

T O P

Zählt bei jedem Öffnen der Arbeitsmappe den Wert in Zelle "A1" um 1 nach oben
Private Sub Workbook_Open ()
Range("A1").Value = Range("A1").Value + 1
End Sub

T O P

Teilt einen in Zelle A1 eingegeben Wert nach ENTER durch 100
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Application.EnableEvents = False
If Target.AddressLocal = "$A$1" Then
Target = Target / 100
End If
Application.EnableEvents = True
End Sub

T O P

Druckt eine bestimmte Seite aus mehrseitigen Arbeitsblättern
Sub Druck_Bestimmte_Seite()
ActiveWindow.View = xlPageBreakPreview
Dim seitenzahl As String
seitenzahl = InputBox(" Geben Sie die Nr. der" & Chr(13) & Chr(13) & "auszudruckenden Seite ein:", "Seitenzahl eingeben")
If seitenzahl = "" Then
MsgBox "Keine Seite ausgewählt"
Exit Sub
Else
ActiveWindow.SelectedSheets.PrintOut From:=seitenzahl, To:=seitenzahl, Copies:=1, Collate _
:=True
ActiveWindow.View = xlNormalView
End If
End Sub

T O P

Löscht nach dem Filtern einer Tabelle die sichtbaren Zeilen
Sub DatensaetzeLoeschen()
Antwort = MsgBox("Alle sichtbaren Zeilen loeschen?", _
vbYesNo, "Zeilen loeschen")
If Antwort = vbNo Then GoTo Ende
Application.ScreenUpdating = False
ErsteZeile = ActiveCell.CurrentRegion.Row + 1
ErsteSpalte = ActiveCell.CurrentRegion.Column
LetzteZeile = ErsteZeile + _
ActiveCell.CurrentRegion.Rows.Count - 2
LetzteSpalte = ErsteSpalte + _
ActiveCell.CurrentRegion.Columns.Count - 1
Set SichtbarerBereich = Range(Cells(ErsteZeile, _
ErsteSpalte), Cells(LetzteZeile, _
LetzteSpalte)).SpecialCells(xlVisible)
AnzahlBereiche = SichtbarerBereich.Areas.Count
For Zaehler = 1 To AnzahlBereiche
Range(SichtbarerBereich.Areas(1).Address).Delete _
Shift:=xlUp
Next
Application.ScreenUpdating = True
Ende:
End Sub

T O P

Sucht über die InputBox eingegebene Daten
Sub Suchen()
Dim rngFind As Range
Dim strFind As String
strFind = InputBox("Daten eingeben:")
If strFind = "" Then Exit Sub
Set rngFind = Cells.Find(strFind, LookAt:=xlPart, LookIn:=xlFormulas)
If rngFind Is Nothing Then
Beep
MsgBox "Daten wurden nicht gefunden!"
Exit Sub
End If
rngFind.Select
End Sub

T O P

Listet alle Verknüpfungen aus Tabelle 1 in Tabelle 2 auf und markiert die Verknüpfungen in Tabelle 1
Sub Alle_Verknüpfung_listen()
Dim zelle As Range
Dim i As Integer
i = 1
For Each zelle In Sheets(1).UsedRange
If zelle.HasFormula Then
If InStr(zelle.Formula, "!") > 0 Then
Sheets(2).Cells(i, 1).Value = zelle.Worksheet.Name & "/" & zelle.Address
Sheets(2).Cells(i, 2).Value = "'" & zelle.Formula
zelle.Interior.Color = vbRed
i = i + 1
End If
End If
Next zelle
End Sub

T O P

Setzt die Symbolleisten auf die Standardeinstellung zurück
Sub SymbolleistenReset()
Dim Leiste As CommandBar
For Each Leiste In CommandBars
If Leiste.Type = msoBarTypeNormal Then
If Leiste.BuiltIn Then Leiste.Reset
End If
Next Leiste
End Sub

T O P

Prüft, ob ein Tabellenblatt vorhanden ist und wählt dieses bei Vorhandensein an
Sub TabAuswahl()
Dim Sh As Worksheet
Dim sName$
sName = InputBox("Bitte Tabellenname auswählen!")
For Each Sh In Worksheets
If InStr(Sh.Name, sName) > 0 Then
Sh.Select
Exit Sub
End If
Next Sh
Beep
MsgBox "Kein Blatt gefunden!"
End Sub

T O P

Fügt nach beliebig wählbarer Zeile neue Zeilen ein
Sub Einfügen()
Dim Letzte As Long
Dim Zeile As Integer
Dim I As Long
Letzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Zeile = Application.InputBox("Nach wieviel Zeilen Leerzeile einfügen", "Zeilenanzahl", 0, Type:=1)
If Zeile = 0 Then Exit Sub
For I = Letzte To 2 Step Zeile * -1
Rows(I).Insert Shift:=xlDown
Next I
End Sub

T O P

Datum und Uhrzeit der letzten Datensicherung (Speicherung) auslesen
Sub Gespeichert_am_um()
Range("A1") = ActiveWorkbook.BuiltinDocumentProperties(12).Value
End Sub

T O P

Datum und Uhrzeit der Dateierstellung auslesen
Sub Erstellt_am_um()
Range("A1") = ActiveWorkbook.BuiltinDocumentProperties(11).Value
End Sub

T O P

Speichert die Datei beim Schliessen oder Beenden
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ActiveWorkbook.Save
End Sub

T O P

Liest den letzten in Spalte A eingetragenen Wert in Zelle B1 ein
Sub LetztenWertKopieren()
   Dim intCol As Integer
   intCol = 1 '1 steht für Spalte A
   Cells(Rows.Count, intCol).End(xlUp).Copy _
   Range("B1")
End Sub

T O P

Liest alle verfügbaren Schriftarten aus
Sub SchriftAuslesen()
    Dim cnt As CommandBarControl
    Dim intCounter As Integer
    Application.ScreenUpdating = False
    Set cnt = Application.CommandBars.FindControl(ID:=1728)
    For intCounter = 1 To cnt.ListCount
       With Cells(intCounter, 1)
          .Value = cnt.List(intCounter)
          .Font.Name = cnt.List(intCounter)
       End With
    Next intCounter
    Columns(1).AutoFit
    Application.ScreenUpdating = True
End Sub

T O P

Liest den festgelegten Druckbereich aus
Sub Druckbereich()
If ActiveSheet.PageSetup.PrintArea = "" Then
MsgBox "Es ist kein Druckbereich festgelegt"
Else
MsgBox "Druckbereich: " & ActiveSheet.PageSetup.PrintArea
End If
End Sub

T O P

Abfrage, ob Blattschutz eingeschaltet ist oder nicht
Sub Blattschutz_Ja_Nein()
If ActiveSheet.ProtectContents = True Then
MsgBox "Dieses Arbeitsblatt ist geschützt, heben Sie den Blattschutz auf !", 64, "BLATTSCHUTZ"
Exit Sub
End If
If ActiveSheet.ProtectContents = False Then
MsgBox "Dieses Arbeitsblatt ist NICHT geschützt !", 64, "BLATTSCHUTZ"
Exit Sub
End If
End Sub

T O P

Automatische Anpassung Spaltenbreite und Zeilenhöhe (in "Diese Arbeitsmappe")
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)
x = Target.Row
y = Target.Column
ActiveSheet.Rows(x).AutoFit
ActiveSheet.Columns(y).AutoFit
End Sub

T O P

Aktive Zelle gelb unterlegen (in "Diese Arbeitsmappe")
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)
Static OldIndex As Integer
Static OldCell As Range
On Error Resume Next
OldCell.Interior.ColorIndex = OldIndex
If Not OldCell Is Nothing Then
OldIndex = Target.Interior.ColorIndex
End If
Target.Interior.ColorIndex = 6
Set OldCell = Target
End Sub

T O P

Datum und Uhrzeit der letzten Zelländerung als Kommentar ausgeben (in Tabellenblatt)
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Target.NoteText "Die Zelle wurde am " & Format(Date, "dd.mm.yy") & " um " & Format(Now(), " hh:mm:ss") & " durch " & ActiveWorkbook.BuiltinDocumentProperties(7).Value & " geändert."
End Sub

T O P

Dateipfad und -name in Fusszeile stempeln
Sub Dateipfad()
Worksheets(1).PageSetup.LeftFooter = ThisWorkbook.FullName
End Sub
T O P

Tabellenblätter alphabetisch sortieren
Sub BlaetterSortieren()
Dim iMax As Integer
Dim Ibl As Integer
Dim ibl2 As Integer
Application.ScreenUpdating = False
iMax = ThisWorkbook.Sheets.Count
For Ibl = 1 To iMax
For ibl2 = Ibl To iMax
If UCase(Sheets(ibl2).Name) _
< UCase(Sheets(Ibl).Name) Then
Sheets(ibl2).Move before:=Sheets(Ibl)
End If
Next ibl2
Next Ibl
Application.ScreenUpdating = True
End Sub

T O P

Verknüpfung zu anderen Workbooks finden
Sub Verknüpfungen_finden()
Dim Zelle As Object, ersteAdresse$
'erste Verknüpfung finden
Set Zelle = Cells.Find(What:="]", LookIn:=xlFormulas)
If Not Zelle Is Nothing Then
    ersteAdresse = Zelle.Address
    MsgBox "Verknüpfung in: " & ersteAdresse & _
        Chr(10) & Chr(10) & "Verknüpfung: " & _
        Chr(10) & Range(Zelle.Address).Formula
    'weitere Verknüpfungen finden
    Do
        Set Zelle = Cells.FindNext(Zelle)
        If Zelle.Address = ersteAdresse Then Exit Do
        MsgBox "Verknüpfung in: " & Zelle.Address & _
            Chr(10) & Chr(10) & "Verknüpfung: " & _
            Chr(10) & Range(Zelle.Address).Formula
    Loop While Not Zelle Is Nothing And Zelle.Address <> ersteAdresse
End If
End Sub

T O P

Löscht einen Zeilenumbruch in der aktiven Zelle
Sub Umbruch_rueckgaengig()
ActiveCell.Value = _
WorksheetFunction.Substitute(ActiveCell.Value, vbLf, "")
End Sub

T O P

Setzt den Wert in A1 auf den Grundwert 10 zurück, wenn Eingabewert gelöscht wird (in Tabellenblatt)
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Address = "$A$1" And IsEmpty(Target) = True Then Target = "10"
End Sub

T O P

Öffnet den Schacht des CD-ROM-Laufwerks (in Tabellenblatt)
Private Declare Function mciExecute Lib "winmm.dll" _
(ByVal lpstrCommand As String) As Long

Sub CD_oeffnen()
Call mciExecute("Set CDaudio door open")
End Sub
T O P

Schliesst den Schacht des CD-ROM-Laufwerks (in Tabellenblatt)
Private Declare Function mciExecute Lib "winmm.dll" _
(ByVal lpstrCommand As String) As Long

Sub CD_oeffnen()
Call mciExecute("Set CDaudio door closed")
End Sub

T O P

Schaltet den Computer aus (in Diese Arbeitsmappe)
Declare Function ExitWindowsEx& Lib "user32" (ByVal uFlags&, ByVal wReserved&)

Global Const EWX_FORCE = 8
Global Const EWX_LOGOFF = 0
Global Const EWX_REBOOT = 2
Global Const EWX_SHUTDOWN = 1

Sub Tschuess()
Dim LResult
LResult = ExitWindowsEx(EWX_SHUTDOWN, 0&)
End Sub

T O P

Liest alle Dateinamen aus dem in B1 angegebenen Verzeichnis aus
Option Explicit

Sub ReadFiles()
   Dim iCounter As Integer
   With Application.FileSearch
      .LookIn = Range("B1").Value
      .Filename = "*.xls"
      .Execute
      For iCounter = 1 To .FoundFiles.Count
         Cells(iCounter + 1, 1).Value = Dir(.FoundFiles(iCounter))
      Next iCounter
   End With
End Sub
T O P

Delete-Taste bei Formel in Zelle deaktivieren (In Tabellenblatt)
Option Explicit

Private Sub Worksheet_Deactivate()
   Application.OnKey "{del}"
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Target.HasFormula Then
      Application.OnKey "{del}", ""
   Else
      Application.OnKey "{del}"
   End If
End Sub
T O P

Zellwert im Kommentar anzeigen
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    'Von Thomas Ramel
    Dim rngZelle As Range
    Dim rngNachfolger As Range
    On Error Resume Next
    For Each rngZelle In Target
        rngZelle.NoteText Format(rngZelle.Value, "#,##0.00")
        For Each rngNachfolger In rngZelle.Dependents
            rngNachfolger.NoteText Format(rngNachfolger.Value, "#,##0.00")
        Next rngNachfolger
    Next rngZelle
End Sub
T O P

Tabellenblattnamen auslesen (Modul in "Diese Arbeitsmappe")
Sub Tabellennamen_auflisten()
  'Sisto Salera 24.06.2003
  Dim MyListe$, MyCell$, Anzahl%, MyRange$, Ok%, i%
  MyListe = ActiveSheet.Name
  MyCell = ActiveCell.Address
  Anzahl = Worksheets.Count
  MyRange = Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row + Anzahl - 1, ActiveCell.Column)).Address
  Worksheets(MyListe).Range(MyRange).Select
  Ok = MsgBox("ACHTUNG: Der markierte Bereich wird überschrieben !" & vbCrLf & _
              Chr(13) & "                         Trotzdem fortfahren ?", vbYesNo)
  If Ok <> vbYes Then Exit Sub
  For i = 1 To Worksheets.Count
    Sheets(MyListe).Cells(Range(MyCell).Row + i - 1, Range(MyCell).Column) = Sheets(i).Name
  Next i
  Range(MyCell).Select
  MsgBox ("Es befinden sich ") & ThisWorkbook.Worksheets.Count & (" Tabellenblätter in dieser Arbeitsmappe."), vbOKOnly, ThisWorkbook.Name
End Sub
T O P

Arbeitsmappe nach Änderungen ohne Speichern schliessen (Modul in "Diese Arbeitsmappe")
Sub Ohne_Speichern_schliessen()
ThisWorkbook.Close Saved = True

'oder ThisWorkbook.Close False
End Sub

T O P

Persönlichen Assistenten rufen
Sub assist()
Application.Assistant.Visible = True
Assistant.Animation = msoAnimationIdle
Set SB = Assistant.NewBalloon
SB.Animation = msoAnimationCheckingSomething
SB.BalloonType = msoBalloonTypeButtons
SB.Heading = " H A L L O ! ! ! "
SB.Text = _
"Ich bin Dein persönlicher Assistent"
If SB.Show = msoBalloonButtonOK Then
Assistant.Visible = False
End If
End Sub
T O P

AutoKorrektur-Liste auslesen, bearbeiten und zurückschreiben
Option Explicit
'Peter Haserodt 2003

Sub AutoCorrectRead()
    'zum Auslesen, danach Tabelle zum Zielrechner
    Dim oList As Variant, i As Integer
    With Application.AutoCorrect
        oList = .ReplacementList
        For i = 1 To UBound(oList)
            Cells(i, 1) = oList(i, 1)
            Cells(i, 2) = oList(i, 2)
        Next i
    End With
End Sub

Sub AutoCorrectWrite()
    'zum wiedereinlesen - fehlende werden gesetzt, bestehende überschrieben
    Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("G20").Select
    Dim i As Integer
    With Application.AutoCorrect
        For i = 1 To Range("a1").CurrentRegion.Rows.Count
            .AddReplacement Cells(i, 1), Cells(i, 2)
        Next i
    End With
End Sub
T O P

"Glätten" eines Bereichs
Sub BereichGlaetten()
    'von Klaus "Klausimausi64" Weck
    Dim r As Range, c As Range
    On Error Resume Next
    Set r = Application.InputBox("Bereich markieren, der geglättet werden soll: ", Type:=8)
    For Each c In r.Cells
    c.Value = Application.WorksheetFunction.Trim(c.Value)
    Next c
End Sub
T O P

In Zelle A1 angegebene Anwendung (*.exe) starten / beenden
Public id
Sub starten()
id = Shell(Range("A1").Value, vbNormalFocus)
End Sub
Sub beenden()
AppActivate id
SendKeys "%{F4}", True
End Sub
T O P

Datei bei jedem Beenden speichern (In "Diese Arbeitsmappe")
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
End Sub
T O P

"Entfernen"-Taste bei Formel in Zelle oder im markierten Bereich deaktivieren
'************************
'*  von Peter Haserodt  *
'************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim oRange As Range
    Application.EnableEvents = False
    On Error GoTo Fehler:
    If Target.Cells.Count = 1 Then
        If Target.HasFormula Then
        MsgBox "In dieser Zelle befindet sich eine Formel oder ein Verweis." & vbLf & vbLf & "  Ein Entfernen ist nur in der Bearbeitungsleiste möglich !", vbOKOnly, "www.kmbuss.de"
            Application.OnKey "{del}", ""
        Else
            Application.OnKey "{del}"
        End If
    Else
        Set oRange = Target.SpecialCells(xlCellTypeFormulas)
        MsgBox "Es befinden sich Formeln oder Verweise im markierten Bereich." & vbLf & vbLf & "     Ein Entfernen ist nur in der Bearbeitungsleiste möglich !", vbOKOnly, "www.kmbuss.de"
        Application.OnKey "{del}", ""
    End If
Aufraeumen:
    Application.EnableEvents = True
    Exit Sub
Fehler:
    Application.OnKey "{del}"
    Resume Aufraeumen
End Sub
T O P

Cursor (Mauszeiger) positionieren
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
'***************
'* von Nepumuk *
'***************
Sub Cursor1()
SetCursorPos 540, 350 'hier die Bildschirmposition anpassen
End Sub
T O P

Schliessen einer UserForm mit Klick auf "X" verhindern (Code hinter die UserForm)
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
MsgBox "UserForm kann nur mit Klick auf 'Beenden' geschlossen werden !"
Cancel = True
End If
End Sub
T O P

Einfügen von Zellkomentaren nur nach vorheriger Passworteingabe möglich
Private Sub Workbook_Open()
Dim passwort As String
    passwort = InputBox("Bitte geben Sie das Passwort" & Chr(13) & Chr(13) & "  für das Einfügen von Kommentaren ein:", "Passwortabfrage für das Einfügen von Kommentaren")
    If passwort <> "36" Then
    MsgBox "     Das Kennwort ist ungültig," & Chr(13) & Chr(13) & "Sie dürfen keine Kommentare einfügen !"
    Application.CommandBars("Worksheet Menu Bar").Controls("Einfügen").Controls("Kommentar").Enabled = False
    Application.CommandBars("Cell").Controls("Kommentar einfügen").Enabled = False
Exit Sub
Else
    Application.CommandBars("Worksheet Menu Bar").Controls("Einfügen").Controls("Kommentar").Enabled = True
    Application.CommandBars("Cell").Controls("Kommentar einfügen").Enabled = True
End If
End Sub
T O P

Spaltenbreite nach Markieren der Zelle D2 ändern, nach Markieren einer anderen Zelle zurücksetzen
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Zelle = Target.Address
Select Case Zelle
Case "$D$2"
Range("$D$2").ColumnWidth = 52 'entspricht 369 Pixel
Case Else
Range("$D$2").ColumnWidth = 16.43 'entspricht 120 Pixel
End Select
End Sub
T O P

Spaltenbreite nach Markieren einer Zelle in Spalte B ändern, nach Markierung einer anderen Zelle zurücksetzen
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range
Set rng = Columns("B:B")
    If Not (Intersect(Target, rng) Is Nothing) Then
        rng.ColumnWidth = 30
    Else
        rng.ColumnWidth = 10.71
    End If
End Sub
T O P

Datum und Uhrzeit der Zugriffe auf die Arbeitsmappe in Spalte B protokollieren
Private Sub Workbook_Open()
With Cells(Sheets("Zugriffsprotokoll").Cells(Rows.Count, 2).End(xlUp).Row + 1, 2)
.Select
.Value = Now
End With
'ActiveWorkbook.Save 'Hochkomma vor ActiveWorkb... entfernen, wenn Mappe automatisch gespeichert werden soll
End Sub
T O P

Ganze Zeile ausblenden, wenn einzelne Zelle leer ist
Sub BlendeAus()
Range("C5:C20").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
End Sub
T O P

Zeilen ausblenden, wenn bestimmter Zellwert gleich Null ist
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If [a1].Value = 0 Then
    Rows("10:20").EntireRow.Hidden = True
    Else
    Rows("10:20").EntireRow.Hidden = False
    End If
End Sub
T O P

AutoFilter zurücksetzen
Sub FilterAufheben()
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
End Sub
T O P