excel-center
Homepage
Newsletter
RSS Feed
CLIP - Programm
Kontakt
Ihre Werbung
Impressum
 Foren
Übersicht
Excel - Diskussionsforum
Excel - Beispieldateien
 Mailinglisten
Excel - Liste
Hilfe zur Excel - Liste
 Software
Freeware
Shareware
Demoprogramme
 Dokumentationen
Online - Handbuch VBA
Excel - FAQ
VBA Schlüsselwörter
Excel Schlüsselwörter
Tabellenfunktionen
 Suchen
Suche im Google - Archiv
Suche im L-Soft - Archiv
Diskussionforum durchsuchen
 Kaufen
Buchtipps
Softwaretipps
 Linksammlungen
Java/JavaScript
Programmierung
Webdesign
 
 
Werbung
Werbung:
 

Handbuch Excel VBA

Version 2.0   29.03.2005
 

Stichwortverzeichnis

A B C D E F G H I J K L M
M O P Q R S T U V W X Y Z

Inhaltsverzeichnis

  • API Aufrufe

  • Arbeitsmappen- und Blattschutz

  • Benutzerinformationen

  • Benutzerdefinierte Funktionen

  • Datenimport und -export, Dateioperationen

  • Makros

  • Menüs und Symbolleisten

  • Kommentare

    • Kommentar per Makro formatieren
    • Zellbereich mit Kommentar versehen
    • Grösse des Kommentarfensters automatisch festlegen
  • Textverarbeitung

  • Zellmanipulationen

  • Sonstige

  • Quellen

  • Index


  • API Aufrufe zum Seitenanfang

    1. Speicherpfad erfragen zum Seitenanfang
    Public Type BROWSEINFO
        hOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type
    '32-bit API-Deklarationen
    Declare Function SHGetPathFromIDList Lib "shell32.dll" _
        Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As
    String) As Long
    Declare Function SHBrowseForFolder Lib "shell32.dll" _
      Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    Sub DirAuswahl()
        Dim msg As String
        msg = "Wählen Sie bitte einen Ordner aus:"
        MsgBox getdirectory(msg)
    End Sub
    Function getdirectory(Optional msg) As String
        Dim bInfo As BROWSEINFO
        Dim Path As String
        Dim r As Long, x As Long, pos As Integer
    '   Ausgangsordner = Desktop
        bInfo.pidlRoot = 0&
    '   Dialogtitel
        If IsMissing(msg) Then
            bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
        Else
            bInfo.lpszTitle = msg
        End If
    '   Rückgabe des Unterverzeichnisses
        bInfo.ulFlags = &h1
    '   Dialog anzeigen
        x = SHBrowseForFolder(bInfo)
    '   Ergebnis gliedern
        Path = Space$(512)
        r = SHGetPathFromIDList(ByVal x, ByVal Path)
        If r Then
            pos = InStr(Path, Chr$(0))
            getdirectory = Left(Path, pos - 1)
        Else
            getdirectory = ""
        End If
    End Function
    
    4. Vorhandensein eines Farbdrucker s prüfen zum Seitenanfang
    Option Explicit
    Declare Function CreateICA Lib "GDI32" (ByVal driver As String, ByVal
    device As String, ByVal Port As String, devmode As Long) As Long
    Declare Function DeleteDC Lib "GDI32" (ByVal hdc As Long) As Boolean
    Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal
    cap
    As Integer) As Integer
    Declare Function RegOpenKeyExA Lib "advapi32" (ByVal hkey As Long,
    ByVal
    subkey As String, ByVal options As Long, ByVal access As Long, ByRef
    newkey As Long) As Long
    Declare Function RegCloseKey Lib "advapi32" (ByVal hkey As Long) As
    Long
    Declare Function RegQueryValueExA Lib "advapi32" (ByVal hkey As Long,
    ByVal entry As String, ByRef reserved As Long, ByRef dtype As Long,
    ByVal retval As String, ByRef datalen As Long) As Long
    Sub Demo()
    'demo
    MsgBox IsColourPrinter, , "Colour Printer?"
    End Sub
    Function IsColourPrinter() As Boolean
    ' *** Alan Warriner 1998 ***
    'alan_warriner@bigfoot.com
    'wrapper for GetPrinterColours function
    'returns TRUE if a colour printer
    'returns FALSE if not colour or an error occurred
    IsColourPrinter = GetPrinterColours > 2
    End Function
    Function GetPrinterColours() As Integer
    ' *** Alan Warriner 1998 ***
    'alan_warriner@bigfoot.com
    'obtain the number of colours active printer is capable of printing
    '2 colours (or less?) indicates mono printer
    'a return value of zero indicates an error
    'error return value
    GetPrinterColours = 0
    On Error GoTo errortrap
    Dim PrinterName As String
    Dim DriverName As String
    Dim DriverFile As String
    Dim Port As String
    Dim newkey, datalen As Long
    Dim OnLocation, tempval As Integer
    Dim hdc As Long
    hdc = 0
    'constants for registry functions
    Const HKEY_LOCAL_MACHINE = &H80000002
    Const ERROR_NONE = 0
    Const REG_SZ As Long = 1
    'constant for device capablity function
    Const NUMCOLORS = 24
    'get active printer name
    PrinterName = Application.ActivePrinter
    'extract printer device name by getting last occurence of ' on '
    OnLocation = 0
    Do
    tempval = InStr(OnLocation + 1, PrinterName, " on ")
    If tempval > 0 Then
    OnLocation = tempval
    End If
    Loop While tempval > 0
    PrinterName = Left(PrinterName, OnLocation - 1)
    'get printer driver name from registry
    If Not GetRegistryEntry(HKEY_LOCAL_MACHINE,
    "System\CurrentControlSet\Control\Print\Printers\" & PrinterName,
    "Printer Driver", DriverName) Then
    Exit Function
    End If
    'get printer port from registry
    If Not GetRegistryEntry(HKEY_LOCAL_MACHINE,
    "System\CurrentControlSet\Control\Print\Printers\" & PrinterName,
    "Port", Port) Then
    Exit Function
    End If
    'get printer driver file name from registry
    If Not GetRegistryEntry(HKEY_LOCAL_MACHINE,
    "System\CurrentControlSet\Control\Print\Environments\Windows
    4.0\Drivers\" & DriverName, "Driver", DriverFile) Then
    Exit Function
    End If
    'remove .xxx extension
    If InStr(DriverFile, ".") Then
    DriverFile = Left(DriverFile, InStr(DriverFile, ".") - 1)
    End If
    'get device context for printer
    hdc = CreateICA(DriverFile, PrinterName, Port, 0&)
    If hdc = 0 Then
    Exit Function
    End If
    'get number of colours printer can use
    GetPrinterColours = GetDeviceCaps(hdc, NUMCOLORS)
    'handle errors
    errortrap:
    'dispose of device context
    If hdc <> 0 Then
    DeleteDC (hdc)
    End If
    Exit Function
    End Function
    Function GetRegistryEntry(ByVal hkey As Long, ByRef entry As String,
    ByRef value As String, ByRef returnstring As String) As Boolean
    ' *** Alan Warriner 1998 ***
    'alan_warriner@bigfoot.com
    'get an entry from the registry
    'return false if unable to
    'otherwise
    'return registry entry STRING in passed parameter 'returnstring'
    'registry function constants
    Const ERROR_NONE = 0
    Const REG_SZ As Long = 1
    Dim newkey, datalen As Long
    'error return value
    GetRegistryEntry = False
    On Error GoTo errortrap
    'try to open registry entry
    If RegOpenKeyExA(hkey, entry, 0&, &H3F, newkey) <> ERROR_NONE
    Then
    Exit Function
    End If
    'get length of registry entry & set passed string length to suit
    RegQueryValueExA newkey, value, 0&, REG_SZ, 0&, datalen
    returnstring = String(datalen, 0)
    'read string data into passed parameter
    If RegQueryValueExA(newkey, value, 0&, REG_SZ, returnstring, datalen)
    <>
    ERROR_NONE Then
    RegCloseKey newkey
    Exit Function
    End If
    'close registry entry
    RegCloseKey newkey
    'return success value
    GetRegistryEntry = True
    'handle errors
    errortrap:
    Exit Function
    End Function
    
    5. Bildschirmauflösung feststellen zum Seitenanfang
    Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As
    Long) As Long
    Const SM_CYSCREEN As Long = 1
    Const SM_CXSCREEN As Long = 0
    Sub GetScreenDimensions()
    Dim lWidth As Long
    Dim lHeight As Long
    lWidth = GetSystemMetrics(SM_CXSCREEN)
    lHeight = GetSystemMetrics(SM_CYSCREEN)
    MsgBox "Screen Width = " & lWidth & vbCrLf & "Screen
    Height = " &
    lHeight
    End Sub
    
    Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long,
    ByVal nIndex As Long) As Long
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc
    As Long) As Long
    Const HORZRES = 8
    Const VERTRES = 10
    Function ScreenResolution()
    Dim lRval As Long
    Dim lDc As Long
    Dim lHSize As Long
    Dim lVSize As Long
    lDc = GetDC(0&)
    lHSize = GetDeviceCaps(lDc, HORZRES)
    lVSize = GetDeviceCaps(lDc, VERTRES)
    lRval = ReleaseDC(0, lDc)
    ScreenResolution = lHSize & "x" & lVSize
    End Function
    Sub GetScreenSize()
    Debug.Print ScreenResolution()
    End Sub
    6. Freier Festplattenplat z zum Seitenanfang
    Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias
    "GetDiskFreeSpaceA" (ByVal lpRootPathName As String,
    lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
    lpNumberOfFreeClusters As Long, _
    lpTotalNumberOfClusters As Long) As Long
    Function GetFreeSpace(ByVal Drive$) As Double
    Dim SecPerCluster&, BytesPerSector&, NumFreeClusters&,
    NumClusters&
    Dim lRet&
    Dim dVal#
    lRet& = GetDiskFreeSpace(Drive$, SecPerCluster&, BytesPerSector&,
    NumFreeClusters&, NumClusters&)
    dVal# = SecPerCluster& * BytesPerSector&
    dVal# = dVal# * NumFreeClusters&
    GetFreeSpace = dVal#
    End Function
    7. Registry-Eintrag auslesen zum Seitenanfang
    Const MAX_STRING As Long = 128
    Public Const REG_BINARY = 3&
    Public Const REG_DWORD = 4&
    Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" _
    (ByVal hkey As Long, _
    ByVal sKey As String, _
    ByRef plKeyReturn As Long) As Long
    Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" _
    (ByVal hkey As Long, _
    ByVal sValueName As String, _
    ByVal dwReserved As Long, _
    ByRef lValueType As Long, _
    ByVal sValue As String, _
    ByRef lResultLen As Long) As Long
    Declare Function RegCloseKey Lib "ADVAPI32.DLL" _
    (ByVal hkey As Long) As Long
    Public Const HKEY_CURRENT_USER = &H80000001
    ' Show the value of an Excel 7 entry
    Sub TestShowExcelText()
    MsgBox GetRegistryValue(HKEY_CURRENT_USER, _
    "software\microsoft\excel\7.0\microsoft excel",
    "DefaultPath")
    End Sub
    'Pass:
    ' (1) the KEY (e.g., HKEY_CLASSES_ROOT),
    ' (2) the SUBKEY (e.g., "Excel.Sheet.5"),
    ' (3) the value's name (e.g., "" [for default] or "whatever")
    Function GetRegistryValue(KEY As Long, SubKey As String, _
    ValueName As String) As String
    Dim Buffer As String * MAX_STRING, ReturnCode As Long
    Dim KeyHdlAddr As Long, ValueType As Long, ValueLen As Long
    Dim TempBuffer As String, Counter As Integer
    ValueLen = MAX_STRING
    ReturnCode = RegOpenKeyA(KEY, SubKey, KeyHdlAddr)
    If ReturnCode = 0 Then
    ReturnCode = RegQueryValueExA(KeyHdlAddr, ValueName, _
    0&, ValueType, Buffer, ValueLen)
    RegCloseKey KeyHdlAddr
    'If successful ValueType contains data type
    ' of value and ValueLen its length
    If ReturnCode = 0 Then
    Select Case ValueType
    Case REG_BINARY
    For Counter = 1 To ValueLen
    TempBuffer = TempBuffer & _
    Stretch(Hex(Asc(Mid(Buffer, Counter, 1)))) & " "
    Next
    GetRegistryValue = TempBuffer
    Case REG_DWORD
    TempBuffer = "0x"
    For Counter = 4 To 1 Step -1
    TempBuffer = TempBuffer & _
    Stretch(Hex(Asc(Mid(Buffer, Counter, 1))))
    Next
    GetRegistryValue = TempBuffer
    Case Else
    GetRegistryValue = Buffer
    End Select
    Exit Function
    End If
    End If
    GetRegistryValue = "Error"
    End Function
    Function Stretch(ByteStr As String) As String
    If Len(ByteStr) = 1 Then ByteStr = "0" & ByteStr
    Stretch = ByteStr
    End Function
    
    [Interner Link] Rech
    8. Netzlaufwerke und Shares feststellen zum Seitenanfang
    Option Explicit
    Option Base 1
    Private Declare Function WNetGetConnection _
    Lib "User" (ByVal LocalName As String, _
    ByVal RemoteName As String, _
    RetLength As Integer) As Integer
    ' 32 Bit version of above
    Private Declare Function WNetGetConnectionA _
    Lib "MPR.DLL" (ByVal LocalName As String, _
    ByVal RemoteName As String, _
    RetLength As Long) As Long
    Sub Netzlaufwerke()
    Dim strServerNames() As String
    Dim intNumServers As Integer
    Dim i As Integer
    ' Initialise string array
    ReDim strServerNames(2, 23) As String
    ' Execute function
    intNumServers = pfGetConnection(strServerNames)
    ' Shrink array to get rid of empty elements
    ReDim Preserve strServerNames(2, intNumServers)
    ' Display results
    For i = 1 To intNumServers
    MsgBox strServerNames(1, i) & " = " & _
    strServerNames(2, i)
    Next
    End Sub
    Function pfGetConnection(ByRef strServers() As String) _
    As Integer
    Dim lngMaxLen As Long
    Dim strLocalName As String
    Dim strRemoteName As String
    Dim intCount As Integer, lngGetConRet As Long
    'Loop through drive letters D to Z
    For intCount = 65 To 90
    ' Length of fixed string pointer
    ' for API call
    lngMaxLen = 255
    ' Drive letter with trailing colon
    strLocalName = Chr(intCount) & ":"
    ' initialise string pointer
    strRemoteName = Space(lngMaxLen)
    ' Feed drive letter into API function
    If Not Application.OperatingSystem Like _
    "*32*" Then
    ' 16 bit version
    lngGetConRet = WNetGetConnection _
    (strLocalName, strRemoteName, _
    CInt(lngMaxLen))
    Else
    ' 32 bit version
    lngGetConRet = WNetGetConnectionA _
    (strLocalName, strRemoteName, _
    lngMaxLen)
    End If
    ' Strip out terminating Null character
    ' and trailing spaces
    strRemoteName = Left(strRemoteName, _
    InStr(strRemoteName, Chr(0)) - 1)
    If Not Len(strRemoteName) = 0 Then
    ' Load drive letter into referenced array
    pfGetConnection = pfGetConnection + 1
    strServers(1, pfGetConnection) = strLocalName
    strServers(2, pfGetConnection) = strRemoteName
    End If
    Next intCount
    End Function
    
    9. NumLock ein- und ausschalten zum Seitenanfang
    Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal
    bScan As Byte, ByVal dwFlags As Long, _
    ByVal dwExtraInfo As Long)
    Public Const VK_NUMLOCK = &H90
    Sub Num_Lock_On()
    keybd_event VK_NUMLOCK, 1, 0, 0
    End Sub
    Sub Num_Lock_Off()
    keybd_event VK_NUMLOCK, 0, 0, 0
    End Sub
    10. Bildschirmauflösung ändern zum Seitenanfang
    Private Declare Function EnumDisplaySettings Lib "user32" Alias
    "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As
    Long, lpDevMode As Any) As Boolean
    
    Private Declare Function ChangeDisplaySettings Lib "user32" Alias
    "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwflags As Long) As
    Long
    
    Const CCDEVICENAME = 32
    Const CCFORMNAME = 32
    Const DM_PELSWIDTH = &H80000
    Const DM_PELSHEIGHT = &H100000
    
    Type DEVMODE
    dmDeviceName As String * CCDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
    End Type
    
    Dim DevM As DEVMODE
    
    '------------------------------------------------------------
    'Comments : Allows changing of screen resolution in Win95
    ' Example: Call ChangeScreenResolution(800,600)
    'Parameters: iWidth, iheight: integer values of resolution
    'Sets : Requested screen resolution or if screen is
    ' already at resolution returns true
    'Returns : None
    'Created by: Bridgett M. Cole, Saltware Computer Services
    'Created : 12/1/97 8:15:58 PM
    '------------------------------------------------------------
    Private Sub ChangeScreenResolution(iWidth As Single, iHeight As Single)
    
    Dim a As Boolean
    Dim i&
    Dim b&
    
    i = 0
    
    Do
    a = EnumDisplaySettings(0&, i&, DevM)
    i = i + 1
    Loop Until (a = False)
    
    DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
    DevM.dmPelsWidth = iWidth
    DevM.dmPelsHeight = iHeight
    b = ChangeDisplaySettings(DevM, 0)
    End Sub
    
    Sub ChangeTo800()
    
    Call ChangeScreenResolution(800, 600)
    
    End Sub
    11. CapsLock einschalten zum Seitenanfang
    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
    
    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
    
    Const VK_CAPITAL = &H14
    Const KEYEVENTF_EXTENDEDKEY = &H1
    Const KEYEVENTF_KEYUP = &H2
    Const VER_PLATFORM_WIN32_NT = 2
    Const VER_PLATFORM_WIN32_WINDOWS = 1
    
    Dim Keys(0 To 255) As Byte
    
    Sub SetCapsOn()
    Dim o As OSVERSIONINFO
    Dim NumLockState As Boolean
    Dim ScrollLockState As Boolean
    Dim CapsLockState As Boolean ' CapsLock handling:
    o.dwOSVersionInfoSize = Len(o)
    GetVersionEx o
    CapsLockState = Keys(VK_CAPITAL)
    If CapsLockState <> True Then 'Turn capslock on
    If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then '===== Win95
    Keys(VK_CAPITAL) = 1
    SetKeyboardState Keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then '===== WinNT
    'Simulate Key Press
    keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
    'Simulate Key Release
    keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY _
    Or KEYEVENTF_KEYUP, 0
    End If
    End If
    End Sub
    
    12. LW und Pfad nach UNC umwandeln zum Seitenanfang
    Option Explicit
    
    Declare Function WNetGetConnection& Lib "mpr.dll" Alias _
        "WNetGetConnectionA" (ByVal lpszLocalName As String, _
        ByVal lpszRemoteName As String, cbRemoteName As Long)
    
    Function PfadNachUnc(ByVal Pfadname As String) As String
    Dim dummy, UncLaufwerk$, Laufwerk$, Pfad$
    On Error GoTo Fehlerbehandlung
        Laufwerk = Left(Pfadname, 2)
        Pfad = Right(Pfadname, Len(Pfadname) - 2)
        If InStr(1, Laufwerk, ":") = 2 Then
            UncLaufwerk = String(1001, 0)
            dummy = WNetGetConnection&(Laufwerk, _
                UncLaufwerk, 1000)
            If dummy <> 0 Then UncLaufwerk = Pfadname: GoTo _
                Fehlerbehandlung
            UncLaufwerk = Left(UncLaufwerk, InStr(1, UncLaufwerk, _
                Chr(0)) - 1) & Pfad
        Else
            UncLaufwerk = Pfadname
        End If
    Fehlerbehandlung:
    PfadNachUnc = UncLaufwerk
    End Function
    
    Sub Test()
    Dim Pfad$
        Pfad = "n:\test"
        Pfad = PfadNachUnc(Pfad)
    End Sub
    Schwimmer
    13. Laufwerkstyp anzeigen zum Seitenanfang
    Die folgende Funktion meldet den Laufwerkstyp. Der Aufruf kann innerhalb einer Zelle in der Form =LaufwerkTyp("G:\") erfolgen.
    Declare Function GetDriveType Lib "kernel32" Alias _
    "GetDriveTypeA" (ByVal nDrive As String) As Long
    
    Function LaufwerkTyp(strLaufwerk As String) As String
      Dim lngRWert As Long
    
      lngRWert = GetDriveType(strLaufwerk)
      Select Case lngRWert
      Case 2
        LaufwerkTyp = "Diskette/Wechselplatte"
      Case 3
        LaufwerkTyp = "Festplatte"
      Case 4
        LaufwerkTyp = "Netzlaufwerk"
      Case 5
        LaufwerkTyp = "CD-ROM"
      Case 6
        LaufwerkTyp = "RAM-Disk"
      Case Else
        LaufwerkTyp = ""
      End Select
    End Function
    
    Die folgende Prozedur setzt auf die Funktion LaufwerkTyp() auf und gibt alle vohandenen Laufwerke in eine Messagebox aus:
    Sub LaufwerkeAuflisten()
      Dim intI As Integer
      Dim strLaufwerk As String
      Dim strTyp As String
    
      For intI = 65 To 90
        strLaufwerk = Chr$(intI) & ":"
        strTyp = LaufwerkTyp(strLaufwerk)
        If strTyp > "" Then
          MsgBox strLaufwerk & " = " & strTyp
        End If
      Next
    End Sub

    Arbeitsmappen- und Blattschutz zum Seitenanfang

    1. Blattschutz durch Makro aus- und einschalten zum Seitenanfang
    Sub SchutzAusEin()
        ActiveSheet.Unprotect "Test"
        MsgBox "Blattschutz ist aufgehoben!"
        ActiveSheet.Protect "Test"
        MsgBox "Blattschutz ist gesetzt!"
    End Sub
    
    Herber
    2. Tastatureingaben abfangen zum Seitenanfang
    Sub Auto_Open()
            Application.OnKey "%{F8}", "TueDiesUndDas"
    End Sub
    Sub TueDiesUndDas()
        MsgBox "Hallo!"
        MsgBox ActiveCell.Address
    End Sub

    Benutzerdefinierte Funktionen zum Seitenanfang

    Excel-Version auslesen zum Seitenanfang
    Function fGetExcelVer() As Integer
    If Application.Version Like "*5*" Then
    fGetExcelVer = 5
    ElseIf Application.Version Like "*7*" Then
    fGetExcelVer = 7
    Else
    fGetExcelVer = 8
    End If
    End Function
    
    Sub PerVersion()
    MsgBox Application.Version
    Select Case Left(Application.Version, 1)
    Case "5"
    MsgBox "Sie verwenden Excel 5"
    Case "7"
    MsgBox "Sie verwenden Excel 7/95"
    Case "8"
    MsgBox "Sie verwenden Excel 8/97"
    Case Else
    MsgBox "Sie verwenden eine unbekannte Excel- Version"
    End Select
    ThisWorkbook.Activate
    End Sub
    Kalenderwoche berechnen zum Seitenanfang
    Function DKW(dat As Date) As Integer
    Dim a As Integer
    a = Int((dat - DateSerial(Year(dat), 1, 1) + _
    ((WeekDay(DateSerial(Year(dat), 1, 1)) + 1) _
    Mod 7) - 3) / 7) + 1
    If a = 0 Then
    a = DKW(DateSerial(Year(dat) - 1, 12, 31))
    ElseIf a = 53 And (WeekDay(DateSerial(Year(dat), 12, 31)) - 1) _
    Mod 7 <= 3 Then
    a = 1
    End If
    DKW = a
    End Function
    Function KWoche(d As Date) As Integer
    'von Christoph Kremer, Aachen
    Dim t&
        t = DateSerial(Year(d + (8 - WeekDay(d)) Mod 7 - 3), 1, 1)
        KWoche = (d - t - 3 + (WeekDay(t) + 1) Mod 7) \ 7 + 1
    End Function
    Stellenzahl auslesen zum Seitenanfang
    Function CountDigits(s As String) As Integer
    Dim i
    For i = 1 To Len(s)
    If Mid(s, i, 1) Like "#" Then
    CountDigits = CountDigits + 1
    End If
    Next i
    End Function
    Ture

    Benutzerinformationen zum Seitenanfang

    1. Benutzernamen auslesen zum Seitenanfang
    Declare Function GetUserName Lib "advapi32.dll" Alias
    "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
    Sub ShowUserName()
    Dim Buffer As String * 100
    Dim BuffLen As Long
    BuffLen = 100
    GetUserName Buffer, BuffLen
    MsgBox Left(Buffer, BuffLen - 1)
    End Sub
    
    Function NetUserName()
    Dim Buffer As String * 100
    Dim BuffLen As Long
    BuffLen = 100
    GetUserName Buffer, BuffLen
    NetUserName = Left(Buffer, BuffLen - 1)
    End Function
    
    2. Excel-Benutzernamen in Fenstertitel anzeigen zum Seitenanfang
    Sub FensterName()
    ActiveWindow.Caption = ActiveWindow _
    .Caption & " " & Application.UserName
    End Sub
    [Interner Link] Herber
    3. Excel-Titelzeile ändern zum Seitenanfang
    Sub TitelWechseln()
        Application.Caption = "Veränderte Titelleiste"
    End Sub
    [Interner Link] Busko

    Datenimport- und Export zum Seitenanfang

    1. CSV-Datei schreiben zum Seitenanfang
    Sub Write_Csv()
    F = FreeFile(0)
    fname = InputBox("Enter the filename with Path:", _
    "Please Enter Output File Name:")
    MsgBox "File Selected is: " & fname
    If fname <> False Then
    Open fname For Output As #F
    Set Rng = ActiveCell.CurrentRegion
    Debug.Print Rng.Address
    FCol = Rng.Columns(1).Column
    LCol = Rng.Columns(Rng.Columns.Count).Column
    Frow = Rng.Rows(1).Row
    Lrow = Rng.Rows(Rng.Rows.Count).Row
    For i = Frow To Lrow
    outputLine = ""
    For j = FCol To LCol
    If j <> LCol Then
    'Semikolon als Texttrennzeichen, kann geändert werden
    outputLine = outputLine & Cells(i, j) & ";"
    Else
    outputLine = outputLine & Cells(i, j)
    End If
    Next j
    Print #F, outputLine
    Next i
    Close #F
    End If
    End Sub
    
    Ogilvy
    Sub schreibeCSV()
    F = FreeFile(0)
    fname = InputBox("Bitte Pfad und Dateinamen der Zieldatei eingeben (z.B.
    c:\tmp\text.csv):", _
    "Eingabe Pfad und Dateiname")
    MsgBox "Der Name der Ausgabedatei lautet: " & fname
    fseparator = InputBox("Bitte das Trennzeichen eingeben:", _
    "Eingabe Trennzeichen")
    MsgBox "Das gewählte Trennzeichen ist: " & fseparator
    If fname <> False Then
    Open fname For Output As #F
    Set Rng = ActiveCell.CurrentRegion
    Debug.Print Rng.Address
    FCol = Rng.Columns(1).Column
    LCol = Rng.Columns(Rng.Columns.Count).Column
    Frow = Rng.Rows(1).Row
    Lrow = Rng.Rows(Rng.Rows.Count).Row
    For i = Frow To Lrow
    outputLine = ""
    For j = FCol To LCol
    If j <> LCol Then
    outputLine = outputLine & Cells(i, j) & fseparator
    Else
    outputLine = outputLine & Cells(i, j)
    End If
    Next j
    Print #F, outputLine
    Next i
    Close #F
    End If
    MsgBox "Vorgang abgeschlossen!"
    End Sub

    2. Zellen nach Datenimport aufbereiten zum Seitenanfang

    Sub DatenUmwandeln()
    Dim MyRange As Range
    Dim Cell As Range
    Application.ScreenUpdating = False
    Set MyRange = ActiveCell.CurrentRegion.Columns(7)
    For Each Cell In MyRange
    Cell.Select
    Application.SendKeys "{F2}+{ENTER}", True
    Next Cell
    End Sub
    Busko
    Sub ZellenAufbereiten()
    
    Dim Cell As Range
    
    For Each Cell In Selection
    Cell.Select
    Application.SendKeys "{F2}+{ENTER}", True
    Next
    End Sub
    [Interner Link] Busko

    3. Existenz einer Datei prüfen zum Seitenanfang

    Function FileExist(Filename As String) As Boolean
    On Error GoTo HandleError
    FileExist = False
    If Len(Filename) > 0 Then FileExist = (Dir(Filename) <> "")
    Exit Function
    HandleError:
    FileExist = False
    If (Err = 1005) Then
    MsgBox "Error - printer missing"
    Resume Next
    Else
    If (Err = 68) Or (Err = 76) Then
    MsgBox "Unit or Path do not exist: " & Filename, vbExclamation
    Resume Next
    Else
    MsgBox "Unexpected error " & Str(Err) & " : " &
    Error(Err), vbCritical
    End
    End If
    End If
    End Function

    Datei löschen zum Seitenanfang

    Sub DelFile()
    If Len(Dir("c:\windows\test.txt")) > 0 Then
       Kill "c:\windows\test.txt"
       MsgBox "Test.txt has been annihilated"
    Else
       MsgBox "Test.Txt never existed"
    End If
    End Sub
    [Interner Link] Ogilvy

    Daten nach Access zum Seitenanfang

    Mit folgendem Code kann ein Datensatz an eine Access-Datenbank angefügt werden: Annahmen: Datenbank = Test.mdb
    Sub TestAdd()
    Dim db As Database
    Dim rs As Recordset
    Set db = OpenDatabase("C:\Test.mdb")
    Set rs = db.OpenRecordset(Name:="Test", Type:=dbOpenDynaset)
    With rs
    .AddNew
    .Fields("Name").Value = Range("A1")
    .Fields("Alter").Value = Range("A2")
    .Update
    End With
    rs.Close
    db.Close
    Set rs = Nothing
    End Sub
    Mappe mit Dateinamen aus Zelle speichern zum Seitenanfang
    Sub Auto_Close() 'unter Namen speichern, welcher in Zelle A1 steht
        Dim f As String; r As Integer
        f = ThisWorkbook.Sheets(1).Cells(1; 1).Value
        If f = "" Then
            f = Application.GetSaveAsFilename( _
            fileFilter:="Excel Workbook
    (*.xls), *.xls")
        If f = False Then
        Exit Sub
        End If
        End If
        r = ThisWorkbook.Sheets(1).Cells(1; 1).Characters.Count
        If ThisWorkbook.Sheets(1).Cells(1; 1).Characters(r - 3).Text
    <> ".xls" Then
            f = f & ".xls"
        End If
        ThisWorkbook.SaveAs Filename:=f
    End Sub
    Held
    Datei öffnen -Menü mit definiertem Pfad starten zum Seitenanfang
    Sub DateiAuswahl()
        Dim WB As Workbook
        Dim TB As Worksheet
        Dim i%
        Dim dName
        Dim dFilter$
        dFilter = "Excel-Dateien(*.xls), *.xls"
        ChDrive "d"
        ChDir "d:\MeineDatenl"
        dName = Application.GetOpenFilename(dFilter)
        If dName = False Then Exit Sub
        Set WB = Workbooks.Open(dName)
        Set TB = WB.Worksheets(1)
        For i = 1 To 20
            TB.Cells(i, 5) = "Spalte E - Zeile " & i
        Next i
    End Sub
    Herber

    Datum als Dateiname zum Seitenanfang

    Option Explicit
    Sub DateAsFilename()
    Dim sFileName As String
    sFileName = Format(Now, "mmddyy") + ".xls"
    ActiveWorkbook.SaveAs sFileName
    End Sub
    Verzeichnisgrösse berechnen zum Seitenanfang
    Option Explicit
    Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type
    Private Const MAX_PATH = 260
    Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
    
    Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
    End Type
    
    Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As
    Long) As Long
    Private Declare Function FindFirstFile Lib "kernel32" Alias
    "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As
    WIN32_FIND_DATA) As Long
    Private Declare Function FindNextFile Lib "kernel32" Alias
    "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As
    WIN32_FIND_DATA) As Long
    
    Function GetDirectorySize(ByVal Root$) As Double
    ' Function to calculate bytes used in Root$ and all subdirectories of Root$.
    ' Root$ should be entered in the form c:\Dir
    
    Dim FData As WIN32_FIND_DATA
    Dim fHand&
    Dim sPath$
    Dim StillOK&
    Dim ByteTotal&
    Dim nPos%
    Dim DirName$
    
    sPath$ = Root$ + "\*.*"
    
    fHand& = FindFirstFile(sPath$, FData)
    
    If fHand& <= 0 Then
    GetDirectorySize = 0
    Exit Function
    End If
    
    ByteTotal& = 0
    Do
    If (FData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) =
    FILE_ATTRIBUTE_DIRECTORY Then
    nPos% = InStr(FData.cFileName, Chr$(0))
    DirName$ = Left$(FData.cFileName, nPos% - 1)
    If DirName$ <> "." And DirName$ <> ".." Then
    ByteTotal& = ByteTotal& + GetDirectorySize(Root$ + "\" +
    DirName$)
    End If
    Else
    ByteTotal& = ByteTotal& + FData.nFileSizeLow
    End If
    
    StillOK& = FindNextFile(fHand&, FData)
    Loop Until StillOK = 0
    
    fHand& = FindClose(fHand&)
    GetDirectorySize = ByteTotal&
    
    End Function
    Dateien eines Verzeichnisbaumes auslesen zum Seitenanfang
    Option Explicit
    
    Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type
    Private Const MAX_PATH = 260
    Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
    
    Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
    End Type
    Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As
    Long) As Long
    Private Declare Function FindFirstFile Lib "kernel32" Alias
    "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As
    WIN32_FIND_DATA) As Long
    Private Declare Function FindNextFile Lib "kernel32" Alias
    "FindNextFileA" _
    (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
    Private nCount&
    
    'Main code =================
    
    Private Sub GetDirectoryListing(ByVal Root$)
    ' Function to calculate bytes used in Root$ and all subdirectories of Root$.
    ' Root$ should be entered in the form c:\Dir
    
    Dim FData As WIN32_FIND_DATA
    Dim fHand&
    Dim sPath$
    Dim StillOK&
    Dim ByteTotal&
    Dim nPos%
    Dim DirName$, FileName$
    
    sPath$ = Root$ + "\*.*"
    
    fHand& = FindFirstFile(sPath$, FData)
    
    If fHand& <= 0 Then
    Exit Sub
    End If
    
    ByteTotal& = 0
    Do
    If (FData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) =
    FILE_ATTRIBUTE_DIRECTORY Then
    nPos% = InStr(FData.cFileName, Chr$(0))
    DirName$ = Left$(FData.cFileName, nPos% - 1)
    If DirName$ <> "." And DirName$ <> ".." Then
    GetDirectoryListing Root$ + "\" + DirName$
    End If
    Else
    nCount& = nCount& + 1
    nPos% = InStr(FData.cFileName, Chr$(0))
    FileName$ = Left$(FData.cFileName, nPos% - 1)
    Cells(nCount&, 1).Value = Root$ + "\" + FileName$
    '
    >>>>>>>>>>>>>>>>>>>>&
    gt;>
    ' If you don't want the path just use:
    ' Cells(nCount&,1).value = FileName$
    End If
    
    StillOK& = FindNextFile(fHand&, FData)
    Loop Until StillOK = 0
    
    fHand& = FindClose(fHand&)
    
    End Sub
    
    Public Sub GetFileList()
    Dim Path$
    
    nCount& = 0
    Path$ = InputBox("Enter the root for the file listing (e.g. 'c:\dir' or
    c:")
    If Len(Path$) = 0 Then Exit Sub
    GetDirectoryListing Path$
    
    End Sub
    
    

    Dialoge und Dialogfenster zum Seitenanfang

    Dialog Positionieren zum Seitenanfang
    Declare Function SetWindowPos Lib "User" (ByVal hwnd%, ByVal _
        hwndAfter%, ByVal x%, ByVal y%, ByVal cx%, ByVal cy%, ByVal _
        Flags%) As Integer
    Declare Function FindWindow Lib "User" (ByVal szClass$, ByVal _
        szTitle$) As Integer
    Const SWP_NOSIZE = 1
    Const SWP_NOMOVE = 2
    Const SWP_NOZORDER = 4
    Const SWP_NOREDRAW = 8
    Const SWP_NOACTIVATE = &h10
    Sub ShowDialogboxByPos(ByVal x%, ByVal y%)
        Dim hwndDlg As Integer
        hwndDlg = FindWindow("bosa_sdm_XL", ActiveDialog.DialogFrame.Text)
        If hwndDlg <> 0 Then
           SetWindowPos hwndDlg, 0, x%, y%, 0, 0, SWP_NOSIZE + _
             SWP_NOACTIVATE + SWP_NOZORDER
        End If
    End Sub 'ShowDialogboxByPos
    
    [Interner Link] Wells
    Sub CentreDialog32()
    On Error Resume Next
    '*** DIMENSION VARIABLES ***
    Dim V_rect As Rect32
    'Variables to retrieve the screen dimensions with GetSystemMetrics
    API.
    Dim V_scrn_w As Long
    Dim V_scrn_h As Long
    'Variable to store the window handle with FindWindow API.
    Dim V_hwnd As Long
    'Variables to calculate the new dimensions for the window.
    Dim V_width As Long
    Dim V_height As Long
    Dim V_left As Long
    Dim V_top As Long
    'Get the handle of the dialog box window - 'bosa_sdm_XL' is the class
    name
    'for an Excel dialog box.
    V_hwnd = FindWindow32("bosa_sdm_XL", ActiveDialog.DialogFrame.Text)
    'Only continue if a valid handle is returned
    If V_hwnd <> 0 Then
    'Get the width and height of the screen in pixels
        V_scrn_w = GetSystemMetrics32(0)
        V_scrn_h = GetSystemMetrics32(1)
    'Get the dimensions of the dialog box window in pixels
        GetWindowRect32 V_hwnd, V_rect
    'Calculate the width and height of the dialog box
        V_width = Abs(V_rect.Right - V_rect.Left)
        V_height = Abs(V_rect.Top - V_rect.Bottom)
    'Calculate the new position of the dialog box in pixels
        V_left = (V_scrn_w - V_width) / 2
        V_top = (V_scrn_h - V_height) / 2
    'Move the dialog box to the centre of the screen
        Movewindow32 V_hwnd, V_left, V_top, V_width, V_height, True
    End If
    End Sub
    'TRY IT HERE!
    Sub ShowDialog()
    ThisWorkbook.DialogSheets("Dialog1").Show
    End Sub
    Bullen
    Steuerungsmenü des Dialogfeld rahmens entfernen zum Seitenanfang
    Declare Function FindWindowA Lib "user32" _
    (ByVal lpClassName As Any, _
    ByVal lpWindowName As String) As Long
    Declare Function GetWindowLongA Lib "user32" _
    (ByVal hwnd As Long, _
    ByVal nIndex As Integer) As Long
    Declare Function SetWindowLongA Lib "user32" _
    (ByVal hwnd As Long, ByVal nIndex As Integer, _
    ByVal dwNewLong As Long) As Long
    Global Const GWL_STYLE = (-16)
    Global Const WS_SYSMENU = &H80000
    ' Assign to dialogframe's OnAction event
    Sub RemoveControlMenuExcel32()
        Dim WindowStyle As Long
        Dim hwnd As Long
        Dim Result
        'bosa_sdm_xl is the class name for an
        'Excel 5/7 dialog box.
        'In Excel 97 it is bosa_sdm_xl8
        '(i.e. XL 5/7 style dialogs in XL97, notuserforms)
        hwnd = FindWindowA("bosa_sdm_xl", ActiveDialog.DialogFrame.Text)
        'Get the current windowstyle
        WindowStyle = GetWindowLongA(hwnd, GWL_STYLE)
        'Turn off the System menu
        WindowStyle = WindowStyle And (Not WS_SYSMENU)
        'Set the style
        Result = SetWindowLongA(hwnd, GWL_STYLE, WindowStyle)
    End Sub
    
    Bullen
    Schliessen eines Dialogfensters verhindern zum Seitenanfang
    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    'Prevent user from closing with the Close box in the title bar.
    If CloseMode <> 1 Then Cancel = 1
    End Sub
    UserForm ohne Titelzeile anzeigen zum Seitenanfang
    Private Declare Function FindWindow Lib "user32" Alias
    "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As
    String) As Long
    Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long,
    ByVal wCmd As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As
    Long, lpRect As RECT) As Long
    Private Declare Function ReleaseCapture Lib "user32" () As Long
    Private Declare Function SendMessage Lib "user32" Alias
    "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As
    Long, lParam As Any) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long,
    ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long,
    ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
    
    Private FensterRegion&, Region&
    Private Hauptfensternummer&, Clientfensternummer&
    Private dummy As Long
    Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
    End Type
    Private Const GW_CHILD = 5
    Private Const WM_NCLBUTTONDOWN = &HA1
    Private Const HTCAPTION = 2
    
    Private Sub UserForm_Initialize()
    Call FensterOhneKopf
    End Sub
    
    Sub FensterOhneKopf()
    Dim Abmessung As RECT
    Dim Abmessung1 As RECT
    Dim Pos1x&, Pos1y&, Pos2x&, Pos2y&
    If FensterRegion <> 0 Then Exit Sub
    UserForm1.BorderStyle = fmBorderStyleSingle
    Call Fensternummer(UserForm1, Abmessung, Abmessung1)
    Pos1x = 0
    Pos1y = (Abmessung1.Top - Abmessung.Top)
    Pos2x = Abmessung.Right - Abmessung.Left
    Pos2y = Abmessung.Bottom - Abmessung.Top
    Region = CreateRectRgn(Pos1x, Pos1y, Pos2x, Pos2y)
    FensterRegion = SetWindowRgn(Hauptfensternummer, Region, True)
    End Sub
    
    'Fensterhandles und Infos über Fenster holen
    Private Sub Fensternummer(Form As Object, Abmessung As RECT, Abmessung1 As RECT)
    Dim Fenstername$, Suchstring$
    Suchstring = "UserForm ohne Titelzeile"
    Fenstername = Form.Caption
    Form.Caption = Suchstring
    Hauptfensternummer = FindWindow(vbNullString, Suchstring)
    Form.Caption = Fenstername
    Clientfensternummer = GetWindow(Hauptfensternummer, GW_CHILD)
    dummy = GetWindowRect(Hauptfensternummer, Abmessung)
    dummy = GetWindowRect(Clientfensternummer, Abmessung1)
    End Sub
    
    'Folgendes ist notwendig, um die Form ohne Titelleiste zu verschieben
    Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,
    ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
    If Hauptfensternummer <> 0 Then
    dummy = ReleaseCapture()
    dummy = SendMessage(Hauptfensternummer, WM_NCLBUTTONDOWN, HTCAPTION, 0)
    End If
    Else
    Unload UserForm1 ' Zum schließen, beim ausprobieren.
    End If
    End Sub
    
    Private Sub CommandButton1_Click()
    Unload Me
    End Sub
    
    
    

    Kommentare zum Seitenanfang

    1. Kommentare per Makro formatieren zum Seitenanfang
    Sub KommentarSchrift()
        Dim Cmt As Comment
        Set Cmt = ActiveCell.AddComment
        Cmt.Text "Mein Kommentar"
        With Cmt.Shape.TextFrame.Characters.Font
            .Name = "Arial"
            .Size = 14
        End With
    End Sub
    2. Zellbereich mit Kommentar versehen zum Seitenanfang
    Sub KommentarFestlegen()
        Dim C As Range
        For Each C In Selection
            If Not C.Comment Is Nothing Then
                C.NoteText "Kommentar!"
            End If
        Next C
    End Sub
    
    Herber
    3. Grösse des Kommentarfensters automatisch festlegen zum Seitenanfang
    Sub Kommentargrösse()
         Dim Kommentarzelle As Range
        Application.DisplayCommentIndicator = xlCommentAndIndicator
        For Each Kommentarzelle In ActiveSheet.Cells.SpecialCells(1)
        Kommentarzelle.Comment.Shape.Select True
        Selection.AutoSize = True
        'Selection.ShapeRange.Width = 150
        'Selection.ShapeRange.Height = 100
        Next Application.DisplayCommentIndicator = xlCommentIndicatorOnly
    End Sub 

    Makroausführung beeinflussen zum Seitenanfang

    1. Makroausführung pausieren zum Seitenanfang
    Sub Pause()
            Application.OnTime Now+TimeValue("00:00:01"), "NextMacro"
    End Sub
    Manville
    Sub ElendeWarterei()
    MsgBox "Die Warterei beginnt beim OK !"
    NeueStunde = Hour(Now())
    NeueMinute = Minute(Now())
    NeueSekunde = Second(Now()) + 10
    WarteZeit = TimeSerial(NeueStunde, NeueMinute, NeueSekunde)
    Application.Wait WarteZeit
    Beep
    MsgBox "Geschafft! 10 Sekunden sind um."
    End Sub
     
    2. Makro durch Veränderung einer Zelle starten zum Seitenanfang
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
        If Target.Address = "$A$1" Or Target.Address = "$A$3"
    Then
            If Range("A1").Value < Range("A3").Value Then
            Macro1
            End If
        End If
    End Sub 
    Private Worksheet_Calculate()
        If Range("A1").Value < Range("A3").Value Then
        Macro1
        End If
    End Sub
    Pearson
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim Schnittpunkt As Range
    Set Schnittpunkt = Application.Intersect(Target, Me.Range("A1:A20"))
    If Schnittpunkt Is Nothing Then
    Exit Sub
    Else
    MsgBox "Jetzt sollte das Makro ausgeführt werden"
    End If
    End Sub
    Friedrich
    3. Makoausführung verbergen zum Seitenanfang
    Sub Screen()
        Application.ScreenUpdating=False
    End Sub
    Sub Screen()
        Application.ScreenUpdating=True
    End Sub
    4. Makroausführung, Unterbrechen verhindern zum Seitenanfang
    Sub Abbruch()
        Application.EnableCancelKey = xlDisabled
    End Sub
    Sub Abbruch()
        Application.EnableCancelKey = xlErrorHandler
    End Sub

    5. Makroausführung nach jeder Eingabe zum Seitenanfang

    Application.OnEntry = "MeinMakro"
    Application.OnEntry = ""
    Dieser Code arbeitet global, d.h. in allen geöffneten Mappen und Tabellen.

    6. Makroausführung nicht durch Sicherheitsabfragen unterbrechen zum Seitenanfang

    Application.DisplayAlerts = False
    Diese Zeile in der ersten Zeile des Makros eintragen.
    7. Makrounterbrechung abfangen zum Seitenanfang
    On Error GoTo EH
    Application.EnableCancelKey = xlErrorHandler
    While 1 = 1 'Schleife
    X = X 'Schleife
    Wend 'Schleife
    Exit Sub
    EH:
    MsgBox "Break Key Hit"
    Application.EnableCancelKey = xlInterrupt
    Pearson
    8. Makros und Code dynamisch erstellen zum Seitenanfang
    Sub OpenProzedurAnlegen()
    Dim nWB As Workbook
    Dim mdlWB As Object
    Set nWB = Workbooks.Add
    Set mdlWB = nWB.VBProject.VBComponents("DieseArbeitsmappe")
    With mdlWB.CodeModule
    .InsertLines 3, "Private Sub Workbook_Open()"
    .InsertLines 4, " Msgbox ""Bin jetzt da!"""
    .InsertLines 5, "End Sub"
    End With
    End Sub
    Sub Loeschen()
    With Workbooks("test.xls").VBProject
    .VBComponents.Remove .VBComponents("Modul1")
    End With
    End Sub
    Sub Loeschen()
    With Workbooks("test.xls").VBProject
    .VBComponents.Remove .VBComponents("Modul1")
    End With
    End Sub
    Herber
    8. Module und Code aus Arbeitsmappe entfernen zum Seitenanfang
    Function bRemoveAllCode(ByVal szBook As String) As Boolean
    
        Const lModule As Long = 1
        Const lOther As Long = 100
    
        Dim lCount As Long
        Dim objCode As Object
        Dim objComponents As Object
        Dim wkbBook As Workbook
    
        On Error GoTo bRemoveAllCodeError
    
        Set wkbBook = Workbooks(szBook)
        Set objComponents = wkbBook.VBProject.VBComponents
        lCount = wkbBook.VBProject.VBComponents.Count
    
        '''Remove all modules & code
        For Each objCode In objComponents
            If objCode.Type = lModule Then
                objComponents.Remove objCode
            ElseIf objCode.Type = lOther Then
                objCode.CodeModule.DeleteLines 1,
    objCode.CodeModule.CountOfLines
            End If
        Next objCode
    
        bRemoveAllCode = True
        Exit Function
    
    bRemoveAllCodeError:
        bRemoveAllCode = False
    End Function
    
    Sub PrepBook()
    If Not bRemoveAllCode(ActiveWorkbook.Name) then MsgBox "An error _
    occurred!", vbCritical,"bRemoveAllCode"
    End sub
    
    Rosenberg

    Menüs und Symbolleisten zum Seitenanfang

    1. Untermenüs durch Makro erstellen zum Seitenanfang
    Sub MenuErstellen()
        Dim MB As CommandBar
        Dim Ctrl1 As CommandBarControl
        Dim Ctrl2 As CommandBarControl
        Dim Ctrl1a As CommandBarControl
        Dim Ctrl1b As CommandBarControl
        Set MB = CommandBars.Add(Name:="Neues Menü", MenuBar:=True)
        Set Ctrl1 = MB.Controls.Add(Type:=msoControlPopup)
        Ctrl1.Caption = "Untermenü1"
        Set Ctrl2 = MB.Controls.Add(Type:=msoControlPopup)
        Ctrl2.Caption = "Untermenü2"
        Set Ctrl1a = Ctrl1.Controls.Add(Type:=msoControlPopup)
        Ctrl1a.Caption = "Daten"
        Set Ctrl1b = Ctrl1.Controls.Add(Type:=msoControlPopup)
        Ctrl1b.Caption = "Übertragen"
        CommandBars("Neues Menü").Visible = True
    End Sub
    
    Herber
    2. Menü "Symbolleisten" deaktivieren/aktivieren zum Seitenanfang
    Sub DisableToolbarMenu()
            CommandBars("Toolbar List").Enabled = False
    End Sub
    Sub DisableToolbarMenu()
        CommandBars("Toolbar List").Enabled = True
    End Sub
    3. Menüs dynamisch ein- und ausblenden zum Seitenanfang
    Private Sub Workbook_Activate()
    MenuBars(xlWorksheet).Menus.Add "&Test Menü"
    Set ml = MenuBars(xlWorksheet).Menus("Test Menü")
    With ml
    .MenuItems.Add Caption:="&Daten erfassen", _
    OnAction:="DatenSpeichern"
    .MenuItems.AddMenu Caption:="&Auswertungen"
    With .MenuItems("Auswertungen")
    .MenuItems.Add Caption:="&Auswertung1", _
    OnAction:=""
    .MenuItems.Add Caption:="A&uswertung2", _
    OnAction:=""
    End With
    End With
    End Sub
    Private Sub Workbook_Deactivate()
    MenuBars(xlWorksheet).Reset
    End Sub
    Private Sub Workbook_Open()
    MenuBars(xlWorksheet).Menus.Add "&Test Menü"
    Set ml = MenuBars(xlWorksheet).Menus("Test Menü")
    With ml
    .MenuItems.Add Caption:="&Daten erfassen", _
    OnAction:="DatenSpeichern"
    .MenuItems.AddMenu Caption:="&Auswertungen"
    With .MenuItems("Auswertungen")
    .MenuItems.Add Caption:="&Auswertung1", _
    OnAction:=""
    .MenuItems.Add Caption:="A&uswertung2", _
    OnAction:=""
    End With
    End With
    End Sub
    Held
    4. Symbolleisten ausblenden zum Seitenanfang
    Sub Verstecken()
    For Each tb in Toolbars
    tb.Visible = False
    Next tb
    End Sub
    [Interner Link] Busko
    5. Shortcut-Menü ein- und ausschalten zum Seitenanfang
    Sub ShortCutOnOff()
    Application.ShortcutMenus(xlWorksheetCell).Enabled = False
    End Sub
    
    Manville
    6. Icons in Symbolleiste deaktivieren zum Seitenanfang
    Sub SymbolGrauen()
    CommandBars("Standard").Controls(1).Enabled = False
    End Sub
    
    7. Symbolleiste positionieren zum Seitenanfang
    Sub NeueSymbolleiste()
    Dim cmdB As CommandBar
        Set cmdB = CommandBars.Add("MyToolbar", temporary:=True)
        With cmdB
            .Left = 50
            .Top = 100
            .Visible = True
        End With
    End Sub
    Herber
    8. ID von Symbolleisten und Symbolen auslesen zum Seitenanfang
    Drei verschiedene Makros könne verwendet werden:
    1. CommandBarControlID_List liefert die IDs der Symbolleisten mit
      Menüpunkt, ID-Nr und Beschreibung
    2. CommandBarFaceID_List liefert alle FaceIDs mit Bild und ID
    3. CommandBar_List liest die Excel-internen Bezeichnungen der
      Menüs, Menüpunkte, deren Typ und ID aus
    Dim cbb As CommandBarButton, ComBar As CommandBar, cbc As CommandBarControl
    
    Sub CommandBarControlID_List()
    Dim a, b, c
    Application.ScreenUpdating = False
    For Each ComBar In Application.CommandBars
    If ComBar.Name = "test" Then ComBar.Delete
    Next
    Set ComBar = Application.CommandBars.Add(Name:="test",
    Position:=msoBarTop)
    b = 0
    c = 1
    For a = 1 To 50000
    On Error Resume Next
    Set cbb = ComBar.Controls.Add(Id:=a)
    
    If Err.Number <> 0 Then GoTo weiter
    cbb.CopyFace
    With Workbooks("FaceIDs").Sheets(1)
    .Cells((c Mod 100) + 1, (c \ 100) + b + 1).Formula = a
    .Cells((c Mod 100) + 1, (c \ 100) + b + 2).Activate
    ActiveSheet.Paste
    .Cells((c Mod 100) + 1, (c \ 100) + b + 3).Formula = cbb.Caption
    End With
    If (c + 1) Mod 100 = 0 Then b = b + 3
    c = c + 1
    weiter:
    Application.CommandBars("test").FindControl(Id:=a).Delete
    Err.Clear
    Next
    End Sub
    
    Sub CommandBarFaceID_List()
    Dim a, b
    Application.ScreenUpdating = False
    For Each ComBar In Application.CommandBars
    If ComBar.Name = "test" Then ComBar.Delete
    Next
    On Error Resume Next
    Set ComBar = Application.CommandBars.Add(Name:="test",
    Position:=msoBarTop)
    Set cbb = ComBar.Controls.Add(Id:=1)
    b = 0
    
    For a = 1 To 3518
    With cbb
    .FaceId = a
    .CopyFace
    End With
    With ThisWorkbook.Sheets(1)
    .Cells((a Mod 100) + 1, (a \ 100) + b + 1).Formula = a
    .Cells((a Mod 100) + 1, (a \ 100) + b + 2).Activate
    ActiveSheet.Paste
    End With
    If (a + 1) Mod 100 = 0 Then b = b + 2
    Next
    End Sub
    
    Sub CommandBar_List()
    Application.ScreenUpdating = False
    Dim a, b, c, cbc, d
    b = 1
    d = 0
    For Each a In Application.CommandBars
    Cells(b + d, 1) = a.Name
    Cells(b + d, 2) = "Item-no: " & b
    For Each cbc In a.Controls
    d = d + 1
    Cells(b + d, 3) = cbc.Caption
    Cells(b + d, 4) = Cells(cbc.Type, 10)
    Cells(b + d, 5) = "Type: " & cbc.Type
    Cells(b + d, 6) = "ID: " & cbc.Id
    Next
    b = b + 1
    Next
    End Sub
    
    Friederich
    9. Menüeintrag neuen Befehl zuordnen zum Seitenanfang
    Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target
    As Excel.Range, Cancel As Boolean)
    
    Set chgEinfügen =
    Application.ShortcutMenus(xlWorksheetCell).MenuItems("Einfügen")
    With chgEinfügen
    .OnAction = "mkrEinfügen"
    End With
    End Sub
    Sub mkrEinfügen()
    Selection.PasteSpecial Paste:=xlValues
    End Sub
    Busko
    10. Quickinfo zuordnen zum Seitenanfang
    Sub QuickInfo()
        Application.Toolbars("SybolleistenName").
           _ToolbarButtons(Indexzahl).Name = "Infotext"
    End Sub

    Texte verändern zum Seitenanfang

    1. Zahl in Text zum Seitenanfang
    Function DollarText(vNumber) As Variant
    'see also Function SpellNumber(ByVal MyNumber), PSS ID Number: Q140704
    Dim sDollars As String
    Dim sCents As String
    Dim iLen As Integer
    Dim sTemp As String
    Dim iPos As Integer
    Dim iHundreds As Integer
    Dim iTens As Integer
    Dim iOnes As Integer
    Dim sUnits(2 To 5) As String
    Dim bHit As Boolean
    Dim vOnes As Variant
    Dim vTeens As Variant
    Dim vTens As Variant
    If Not IsNumeric(vNumber) Then
    Exit Function
    End If
    sDollars = Format(vNumber, "###0.00")
    iLen = Len(sDollars) - 3
    If iLen > 15 Then
    DollarText = CVErr(xlErrNum)
    Exit Function
    End If
    sCents = Right$(sDollars, 2) & "/100 Dollars"
    If vNumber < 1 Then
    DollarText = sCents
    Exit Function
    End If
    sDollars = Left$(sDollars, iLen)
    vOnes = Array("", "One", "Two", "Three",
    "Four", "Five", _
    "Six", "Seven", "Eight", "Nine")
    vTeens = Array("Ten", "Eleven", "Twelve",
    "Thirteen", "Fourteen", _
    "Fifteen", "Sixteen", "Seventeen",
    "Eighteen", "Nineteen")
    vTens = Array("", "", "Twenty", "Thirty",
    "Forty", "Fifty", _
    "Sixty", "Seventy", "Eighty", "Ninety")
    sUnits(2) = "Thousand"
    sUnits(3) = "Million"
    sUnits(4) = "Billion"
    sUnits(5) = "Trillion"
    sTemp = ""
    For iPos = 15 To 3 Step -3
    If iLen >= iPos - 2 Then
    bHit = False
    If iLen >= iPos Then
    iHundreds = Asc(Mid$(sDollars, iLen - iPos + 1, 1)) - 48
    If iHundreds > 0 Then
    sTemp = sTemp & " " & vOnes(iHundreds) & "
    Hundred"
    bHit = True
    End If
    End If
    iTens = 0
    iOnes = 0
    If iLen >= iPos - 1 Then
    iTens = Asc(Mid$(sDollars, iLen - iPos + 2, 1)) - 48
    End If
    If iLen >= iPos - 2 Then
    iOnes = Asc(Mid$(sDollars, iLen - iPos + 3, 1)) - 48
    End If
    If iTens = 1 Then
    sTemp = sTemp & " " & vTeens(iOnes)
    bHit = True
    Else
    If iTens >= 2 Then
    sTemp = sTemp & " " & vTens(iTens)
    bHit = True
    End If
    If iOnes > 0 Then
    If iTens >= 2 Then
    sTemp = sTemp & "-"
    Else
    sTemp = sTemp & " "
    End If
    sTemp = sTemp & vOnes(iOnes)
    bHit = True
    End If
    End If
    
    If bHit And iPos > 3 Then
    sTemp = sTemp & " " & sUnits(iPos \ 3)
    End If
    End If
    Next iPos
    DollarText = Trim(sTemp) & " and " & sCents
    End Function 'DollarText
    Larson
    2. Umlaute ersetzen zum Seitenanfang
    Der folgende Code erstezt die Umlaute in der aktuellen Zellauswahl:
    Sub UmlauteWandeln()
    Dim MyRange As Range
    Dim Cell As Range
    Application.ScreenUpdating = False
    Set MyRange = Selection
    For Each Cell In MyRange
    Selection.Replace What:="ss", Replacement:="ss",
    LookAt:=xlPart, MatchCase:=True
    Selection.Replace What:="ü", Replacement:="ue",
    LookAt:=xlPart, MatchCase:=True
    Selection.Replace What:="Ü", Replacement:="Ue",
    LookAt:=xlPart, MatchCase:=True
    Selection.Replace What:="ö", Replacement:="oe",
    LookAt:=xlPart, MatchCase:=True
    Selection.Replace What:="Ö", Replacement:="Oe",
    LookAt:=xlPart, MatchCase:=True
    Selection.Replace What:="ä", Replacement:="ae",
    LookAt:=xlPart, MatchCase:=True
    Selection.Replace What:="Ä", Replacement:="Ae",
    LookAt:=xlPart, MatchCase:=True
    Next Cell
    End Sub
    [Interner Link] Busko
    2. Gross/Kleinschreibung tauschen zum Seitenanfang
    Sub ToggleCase()
    Dim Upr, Lwr, Ppr
    'Originaladresse speichern
    Set OriginalCell = ActiveCell
    Set OriginalSelection = Selection
    If IsEmpty(ActiveCell) Then GoTo NoneFound
    'Errorhandling
    On Error GoTo Limiting
    If OriginalCell = OriginalSelection Then
    Selection.Select
    GoTo Converting
    Else
    Resume Next
    End If
    Limiting:
    'Auswahl auf gültige Zellen begrenzen
    On Error GoTo NoneFound
    Selection.SpecialCells(xlCellTypeConstants, 3).Select
    Converting:
    'Statusbar ändern
    Application.StatusBar = "Ändere Gross- und Kleinschreibung..."
    For Each DCell In Selection.Cells
    Upr = UCase(DCell)
    Lwr = LCase(DCell)
    If Upr = DCell.Value Then
    DCell.Value = Lwr
    Else
    DCell.Value = Upr
    End If
    Next DCell
    'Statusbar zurücksetzen
    Application.StatusBar = False
    Exit Sub
    NoneFound:
    MsgBox "Alle Zellen der aktuelllen Auswahl enthalten Formeln oder sind
    leer!", vbExclamation, " Fehler aufgetreten"
    OriginalSelection.Select
    OriginalCell.Activate
    End Sub

    3. Minuszeichen umstellen zum Seitenanfang

    Sub MinusUmstellen()
    Range("a1").Select
    Do Until ActiveCell.Value = ""
    altstring = ActiveCell.Value
    längealtstring = Len(altstring)
    längealtstring = längealtstring - 1
    rechteszeichen = Right(altstring, 1)
    If rechteszeichen = "-" Then neuerstring = Left(altstring,
    längealtstring): _
    neuerstring = "-" + neuerstring: ActiveCell.Value = neuerstring
    ActiveCell.Offset(1, 0).Range("A1").Select
    Loop
    End Sub
    Held
    Sub TrailingNegatives()
    'to be used with selected ranges
         For Each Cell In Selection
         Cell.Select
         altstring = ActiveCell.Value
         längealtstring = Len(altstring)
         längealtstring2 = längealtstring - 1
         rechteszeichen = Right(altstring, 1)
         If rechteszeichen = "-" Then neuerstring = _
         Left(altstring, längealtstring2): _
         neuerstring = "-" + neuerstring: ActiveCell.Value = neuerstring
         Next
    
    End Sub

    Zellmanipulationen zum Seitenanfang

    1. Erste leere Zelle in einer Spalte finden zum Seitenanfang
    Sub Finde()
        Columns(MyColumnNumber).SpecialCells(xlCellTypeBlanks).Cells(1)
    End Sub
    
    Sub Finde()
        Cells(Application.WorksheetFunction.CountA(Columns(MyColumnNumber)) + 1,
        MyColumnNumber)
    End Sub
    2. Zellen im Makro ohne Zwischenablage kopieren zum Seitenanfang
    Sub Kopieren()
        Dim aBereich As Range, bBereich As Range
        Set aBereich = Range("A1:B2")
        Set bBereich = Range("F1:G2")
    ''  Werte übertragen
        bBereich.Value = aBereich.Value
    ''  Zahlenformate übertragen
        bBereich.NumberFormat = aBereich.NumberFormat
    End Sub
    
    Herber
    3. Zellen zeilenweise ausfüllen zum Seitenanfang
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Address = "$A$1" Then
    Set actcell = [C1]
    Do While actcell <> ""
    Set actcell = actcell.Offset(0, 1)
    Loop
    actcell.Value = Target.Value
    End If
    End Sub
    5. Erste leere Zelle finden zum Seitenanfang
    Sub Finde()
    Selection.SpecialCells(xlBlanks).Areas(1).Cells(1).Select
    End Sub

    Sonstige zum Seitenanfang

    Fundstellen in Userform auflisten zum Seitenanfang
    Sub FundstellenSuchen()
        Dim C As Range
        Dim Gefunden()
        Dim i%
        For Each C In Tabelle1.Range("A1").CurrentRegion
            If InStr(C, "Zei") > 0 Then
                ReDim Preserve Gefunden(i)
                Gefunden(i) = C.Address(False, False)
                UserForm1.ListBox1.List = Gefunden
                i = i + 1
            End If
        Next C
        UserForm1.Show
    End Sub
    
    Herber [Download] Beispiel
    Inhalt der Zwischenablage löschen zum Seitenanfang
    Application.CutCopyMode= False
    Zeilen ausblenden, mit Summe Nul l zum Seitenanfang
    Sub HideRows()
        For Each rngRow In ActiveSheet.UsedRange.Rows
        If Application.Sum(rngRow) = 0 Then
        rngRow.EntireRow.Hidden = True
        End If
        Next rngRow
    End Sub
    Green
    Sub DeleteRow()
    Dim N As Long
    For N = Selection(1, 1).Row + Selection.Rows.Count - 1 _
            To Selection(1, 1).Row Step -1
        With Cells(N, 1)
        If .Value = 0 And Not .HasFormula Then
            .EntireRow.Delete
        End If
        End With
    Next N
    End sub
    Pearson
    Pfad in Fusszeile zum Seitenanfang
    Sub PfadInFusszeile()
         ActiveSheet.PageSetup.LeftFooter = ActiveSheet.Parent.fullname
    End Sub
    
    Held
    Tabellenname automatisch nach Zellinhalt benennen zum Seitenanfang
    Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
    Excel.Range)
    If Target.Address = Sh.Range("jobNumber").Address Then
    Sh.Name = szRenameSheet(Sh, Target)
    End If
    End Sub
    Private Function szRenameSheet(ByVal Sh As Worksheet, ByVal Target As
    Excel.Range) As String
    Dim szName As String
    If Not IsNull(Target) Then
    szName = CStr(Target.Value)
    With Application.WorksheetFunction
    szName = .Substitute(szName, ":", "")
    szName = .Substitute(szName, "/", "")
    szName = .Substitute(szName, "\", "")
    szName = .Substitute(szName, "?", "")
    szName = .Substitute(szName, "*", "")
    szName = .Substitute(szName, "[", "")
    szName = .Substitute(szName, "]", "")
    End With
    szRenameSheet = Left$(szName, 31)
    End If
    End Function
    Neuberechnung erzwingen zum Seitenanfang
    SendKeys "^%{F9}"
    Manville
    Formeln zählen zum Seitenanfang
    Sub Countformula()
    Dim R As Integer
    R = 0
    Range(Cells(1, 1), Selection.SpecialCells(xlLastCell)).Select
    For Each Cell In Selection
    If Left(Cell.Formula, 1) = "=" Then
    R = R + 1
    End If
    Next Cell
    Selection.SpecialCells(xlFormulas, 23).Select
    MsgBox "Es sind " & R & " Formeln in der Tabelle "
    & _
    ActiveSheet.Name & "enthalten"
    End Sub
    Sub CountFormSub()
    MsgBox ActiveSheet.UsedRange.SpecialCells(xlFormulas).Count
    End Sub
    Function countformulas() As Integer
    Dim x As Range
    Dim y As Integer
    Application.Volatile
    For Each x In ActiveSheet.UsedRange
    If x.HasFormula Then y = y + 1
    Next x
    countformulas = y
    End Function
    Namen löschen zum Seitenanfang
    Sub DeleteAllNames()
            Dim Nm As Name
            For Each Nm In Names
                    Nm.Delete
            Next
    End Sub
    Zufallszahlen zum Seitenanfang
    Sub RandomNumbers()
    Dim Number()
    Dim MyRange As Range
    Dim c As Range
    Set MyRange = Selection
    LastNumber = 100000
    ReDim Number(LastNumber)
    For i = 1 To LastNumber
    Number(i) = i
    Next i
    For Each c In MyRange
    Placement = Int(Rnd() * LastNumber + 1)
    c.Value = Number(Placement)
    dummy = Number(LastNumber)
    Number(LastNumber) = Number(Placement)
    Number(Placement) = dummy
    LastNumber = LastNumber - 1
    Next c
    End Sub
    [Interner Link] Busko
    Emails versenden (Outlook 98) zum Seitenanfang
    Sub Aufruf()
    Call SendMessage(True)
    End Sub
    Sub SendMessage(DisplayMsg As Boolean, Optional AttachmentPath)
    Dim objOutlook As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    Dim objOutlookAttach As Outlook.Attachment
    ' Create the Outlook session.
    Set objOutlook = CreateObject("Outlook.Application")
    ' Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    With objOutlookMsg
    ' Add the To recipient(s) to the message.
    Set objOutlookRecip = .Recipients.Add("Nancy Davolio")
    objOutlookRecip.Type = olTo
    ' Add the CC recipient(s) to the message.
    Set objOutlookRecip = .Recipients.Add("Michael Suyama")
    objOutlookRecip.Type = olCC
    ' Add the BCC recipient(s) to the message.
    Set objOutlookRecip = .Recipients.Add("Andrew Fuller")
    objOutlookRecip.Type = olBCC
    ' Set the Subject, Body, and Importance of the message.
    .Subject = "This is an Automation test with Microsoft Outlook"
    .Body = "This is the body of the message." & vbCrLf & vbCrLf
    .Importance = olImportanceHigh 'High importance
    ' Add attachments to the message.
    If Not IsMissing(AttachmentPath) Then
    Set objOutlookAttach = .Attachments.Add(AttachmentPath)
    End If
    ' Resolve each Recipient's name.
    For Each objOutlookRecip In .Recipients
    objOutlookRecip.Resolve
    Next
    ' Should we display the message before sending?
    If DisplayMsg Then
    .Display
    Else
    .Send
    End If
    End With
    Set objOutlook = Nothing
    End Sub
    

    Sound abspielen zum Seitenanfang

    Sub Auto_Open()
    Worksheets("Sheet1").OnCalculate = "PlayIt"
    End Sub
    Sub PlayIt()
    If Range("A1").Value > 5 Then
    ExecuteExcel4Macro ("SOUND.PLAY(,
    ""C:\Windows\Media\Tada.wav"")")
    End If
    End Sub
    Green
    Declare Function sndPlaySound32 Lib "winmm.dll" Alias _
    "sndPlaySoundA" (ByVal lpszSoundName As String, _
    ByVal uFlags As Long) As Long
    Sub Klang()
    Call sndPlaySound32("D:\Programme\ICQ\Connect.wav", 0)
    End Sub
    [Interner Link] Pearson
    Sub PlayMIDI()
    Dim Player
    Player = Shell("C:\Progra~1\Window~1\mplayer2.exe
    C:\Songs\regypti.mid", 6)
    AppActivate Player
    End Sub
    Staff

    Seitenzahlen in Zelle zum Seitenanfang

    Sub SeitenNr()
    Dim Trennzeile As Variant
    Dim AlteZeile As Integer
    Dim Trennspalte As Variant
    Dim AlteSpalte As Integer
    Dim V_Seitenanzahl As Integer
    Dim H_Seitenanzahl As Integer
    Dim V_Seite As Integer
    Dim H_Seite As Integer
    V_Seitenanzahl = 0
    V_Seite = 0
    AlteZeile = 0
    AlteSpalte = 0
    Do
    V_Seitenanzahl = V_Seitenanzahl + 1
    Trennzeile = ExecuteExcel4Macro("INDEX(GET.DOCUMENT(64)," &
    V_Seitenanzahl & ")")
    If IsError(Trennzeile) Then Exit Do
    If Trennzeile <= AlteZeile Then Exit Do
    AlteZeile = Trennzeile
    If Trennzeile >= ActiveCell.Row And V_Seite = 0 Then
    V_Seite = V_Seitenanzahl
    End If
    Loop
    V_Seitenanzahl = V_Seitenanzahl - 1
    H_Seitenanzahl = 0
    H_Seite = 0
    Do
    H_Seitenanzahl = H_Seitenanzahl + 1
    Trennspalte = ExecuteExcel4Macro("INDEX(GET.DOCUMENT(65)," _
    & H_Seitenanzahl & ")")
    If IsError(Trennspalte) Then Exit Do
    If Trennspalte <= AlteSpalte Then Exit Do
    AlteSpalte = Trennspalte
    If Trennspalte >= ActiveCell.Column And H_Seite = 0 Then
    H_Seite = H_Seitenanzahl
    End If
    Loop
    H_Seitenanzahl = H_Seitenanzahl - 1
    If ActiveSheet.PageSetup.Order = xlOverThenDown Then
    ActiveCell.Formula = "Seite " & (V_Seite - 1) * H_Seitenanzahl +
    H_Seite & " von " & H_Seitenanzahl * V_Seitenanzahl
    Else
    ActiveCell.Formula = "Seite " & (H_Seite - 1) * V_Seitenanzahl +
    V_Seite & " von " & H_Seitenanzahl * V_Seitenanzahl
    End If
    End Sub
    Steffens
    Arbeitsmappen vergleichen zum Seitenanfang
    Sub CompareWorkbooks()
    Dim iWB As Integer, iWS As Integer
    Dim rngObj As Range
    
    If Workbooks(1).Worksheets.Count <> Workbooks(2).Worksheets.Count Then
    MsgBox "Number of worksheets differs"
    Exit Sub
    End If
    
    For iWS = 1 To Workbooks(1).Worksheets.Count
    If Workbooks(1).Worksheets(iWS).UsedRange.Cells.Count <>
    Workbooks(2).Worksheets(iWS).UsedRange.Cells.Count Then
    MsgBox "Number of used cells in sheet " & iWS & "
    differs"
    Exit Sub
    End If
    
    For Each rngObj In Workbooks(1).Worksheets(iWS).UsedRange
    If rngObj.Value <> Workbooks(2).Worksheets(iWS).Range(rngObj.Address).Value
    Then
    For iWB = 1 To 2
    Workbooks(iWB).Worksheets(iWS).Activate
    ActiveSheet.Range(rngObj.Address).Activate
    Next
    
    MsgBox "Difference detected at sheet " & iWS & " at cell
    " & rngObj.Address(False, False)
    Exit For
    End If
    Next
    Next
    End Sub
    Veenbaas
    Excel - Fenster positionieren zum Seitenanfang
    Sub InTheMiddle()
    
    Dim dWidth As Double, dHeight As Double
    
    With Application
    .WindowState = xlMaximized
    dWidth = .Width
    dHeight = .Height
    
    .WindowState = xlNormal
    .Top = dHeight / 4
    .Height = dHeight / 2
    
    .Left = dWidth / 4
    .Width = dWidth / 2
    End With
    
    End Sub
    Bullen
    Tabellenblätter sortieren zum Seitenanfang
    Sub SortSheets()
    Dim i As Integer, j As Integer
    For i = 1 To Sheets.Count
    For j = 1 To Sheets.Count - 1
    If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
    Sheets(j).Move after:=Sheets(j + 1)
    End If
    Next j
    Next i
    End Sub
    
    Durch Änderung des < - Zeichens in ein > - Zeichen kann eine absteigende Sortierung erreicht werden. Held
    Fußzeilen bei doppelseitigem Ausdruck zum Seitenanfang
    Sub Datum_in_Fusszeile()
    
    Dim SeitenNummer%, X%
    Dim Zaehler As Boolean
    
    
    Zaehler = True
    X = ExecuteExcel4Macro("get.document(50)")
    
    For SeitenNummer = 1 To X
    If Zaehler = True Then
    With ActiveSheet.PageSetup
    .RightFooter = "&D"
    .LeftFooter = ""
    End With
    End If
    
    If Zaehler = False Then
    With ActiveSheet.PageSetup
    .RightFooter = ""
    .LeftFooter = "&D"
    End With
    End If
    
    ActiveWindow.SelectedSheets.PrintOut _
    From:=SeitenNummer, To:=SeitenNummer, Copies:=1
    
    Zaehler = Not Zaehler
    
    Next SeitenNummer
    
    End Sub
    
    Busko

    A zum Stichwortverzeichnis

    API Aufrufe
    Arbeitsmapenschutz
    Arbeitsmappen, vergleichen

    B zum Stichwortverzeichnis

    Blattschutz
    Blattschutz , Makrosteuerung
    Bildschirmauflösung feststellen
    Bildschirmauflösung , ändern
    Benutzerdefinierte Funktionen
    Benutzernamen , auslesen, Netzwerk
    Benutzernamen , auslesen, Excel

    C zum Stichwortverzeichnis

    Code , aus Arbeitsmappe entfernen
    CapsLock , einschalten
    CSV , Datei schreiben

    D zum Stichwortverzeichnis

    Datum , als Dateiname
    Datei löschen
    Datei öffnen , Dialog mit definiertem Pfad öffen (Makro)
    Dialog positionieren (API)
    Dialogfeld , Steuerungsmenü entfernen
    Dialogfenste r, schliessen verhindern
    Datenimport
    dynamisch, Makro erstellen

    E zum Stichwortverzeichnis

    ENTER
    Existenz, einer Datei prüfen

    F zum Stichwortverzeichnis

    Farbdrucker , auf Vorhandensein prüfen (API)
    Fenster positionieren , Excel
    Formeln zählen
    F2
    Funktionen , benutzerdefinierte
    Fußzeilen , bei doppelseitigem Ausdruck

    G zum Stichwortverzeichnis

    Grossschreibung , ändern

    H zum Stichwortverzeichnis

     

    I zum Stichwortverzeichnis

    Icons , in Symbolleiste ausblenden
    ID , von Symbolen und Symbolleisten auslesen

    J zum Stichwortverzeichnis

     

    K zum Stichwortverzeichnis

    Kalenderwoche , berechnen
    Klang , abspielen
    Kleinschreibung , ändern
    Kommentare
    Kommentare , Grösse des Kommentarfensters automatisch festlegen

    L zum Stichwortverzeichnis

    leere Zelle finden , erste einer Spalte

    M zum Stichwortverzeichnis

    Mails versenden , Outlook
    Menüpunkte durch Makro deaktivieren
    Makro durch Veränderung einer Zelle starten
    Maroausführung nach jeder Eingabe
    Makroausführung pausieren
    Makoausführung verbergen
    Makroausführung, Unterbrechen verhindern
    Makroausführung, Sicherheitsabfragen verhindern
    Makrounterbrechnung abfangen , Errorhandler
    Menüeintrag , neuen Befehl zuweisen
    Menüeintrag , neues Makro zuweisen
    Menüs , durch Makro erstellen
    Menüs , dynamisch ein- und ausblenden
    MIDI - Dateien abspielen
    Minuszeichen , von rechts nach links stellen
    Module entfernen

    N zum Stichwortverzeichnis

    Namen , löschen
    Neuberechnung erzwingen
    Netzlaufwerk , verbundene auslesen
    NumLock , ein- und ausschalten

    O zum Stichwortverzeichnis

    Outlook , Emails versenden

    P zum Stichwortverzeichnis

    Pfad in Fusszeile
    Pfad und LW , nach UNC umwandeln
    positionieren , des Excel - Fensters
    positionieren , Symbolleisten

    Q zum Stichwortverzeichnis

    Quickinfo zuordnen  

    R zum Stichwortverzeichnis

    Registry auslesen

    S zum Stichwortverzeichnis

    Schliessen, Alt + F4, Menüpunkt entfernen
    Schliessen , eines Dialogfensters verhindern
    Seitenzahlen , in Zelle anzeigen
    Shortcut-Menü , ein- und ausschalten
    Spalte ausblenden , mit Summe Null
    Speichern , Datei mit Dateinamen aus einer Zelle
    Speicherpfad , durch API-Aufruf erfragen
    Speichern , Datei mit Dateinamen aus einer Zelle
    Stellenzahl auslesen
    Steuerungsmenü entfernen
    Symbolleisten , positionieren
    Symbolleisteneintrag , neuen Befehl zuweisen
    Symbolleisteneintrag , neues Makro zuweisen

    T zum Stichwortverzeichnis

    Tabellenname , automatisch nach Zellinhalt benennen
    Tastatureingaben abfangen
    Titelzeile verändern
    Titelzeile, UserForm ohne

    U zum Stichwortverzeichnis

    Umlaute ersetzen
    UNC , aus Laufwerksbuchtaben mit Pfad umwandeln
    Unte rmenüs , durch Makro erstellen
    UserForm , Fundstellen auflisten
    UserForm , ohne Titelzeile anzeigen

    V zum Stichwortverzeichnis

    vergleichen , von Arbeitsmappen
    Verschieben , Menüpunkt entfernen
    Verzeichnisbaum , auslesen
    Verzeichnisgrösse , berechnen

    W zum Stichwortverzeichnis

    WAV - Datei , abspielen

    X zum Stichwortverzeichnis

     

    Y zum Stichwortverzeichnis

     

    Z zum Stichwortverzeichnis

    Zahl in Text
    Zeile löschen , wenn Summe Null
    Zellen, zeilenweise ausfüllen
    Zellmanipulationen
    Zufallszahlen
    Zwischenablage , Inhalt löschen

    Quellen zum Seitenanfang

    Bovey [Email] Rob Bovey
    The Baarns Consulting Group
    [External Link] http://www.baarns.com
    Bullen [Email] Stephen Bullen
    Microsoft MVP - Excel
    Homepage: [External Link] http://www.bmsltd.ie/Excel/Default.htm
    Busko [Email] Bernd Busko
    Homepage: http://www.excel-center.de/
    Friederich [Email] Roger Friederich
    Green [Email] John Green
    Microsoft MVP - Excel
    Held [Email] Bernd Held
    Microsoft MVP - Excel
    Machero's Homepage: [External Link] http://members.aol.com/Machero
    Herber [Email] Hans W. Herber
    Microsoft MVP - Excel
    Herber's Excel-Server
    Homepage: [External Link] http://www.herber.de
    Larson [Email] Myrna Larson
    Manville   [Email] Bill Manville
    Microsoft MVP - Excel
    The Spreadsheet Page
    Homepage: [External Link] http://www.j-walk.com/ss
    Ogilvy [Email] Thomas Ogilvy
    Pearson [Email] Chip Pearson
    [External Link] http://home.gvi.net/~c pearson/excel.htm
    Rech [Email] Jim Rech
    Rosenberg [Email] Robert Rosenberg
    Microsoft MVP -Excel
    RCOR Consulting
    Homepage: [External Link] http://ntware.com
    Schwimmer [Email] Michael Schwimmer
    Staff [Email] Harald Staff
    Steffens [Email] Andreas Steffens
    Ture [Email] Ture Magnusson
    Microsoft MVP - Excel
    Turedata AB
    Homepage: [External Link] http://www.turedata.se
    Veenbaas [Email] Sjouke Veenbaas