VBA Excel

Inhaltsverzeichnis

 

 

 

 

 

Excel 2002 Registerkarten Färben

 

Excel Active Workbook etc. abfragen

 

Excel addieren anhand der Farbe der Fonts

 

Excel Adressen suchen über eine Userform

 

Excel Adressen über eine Userform erfassen

 

Excel Alle anderen geöffneten Dateien werden gespeichert und unbemerkt geschlossen

Excel Alle Blattnamen in einer Messagebox anzeigen

Excel Alle Ereignisse abschalten (z.b. Makro "Worksheet_Change" temporär ausschalten)

Excel Alle Farb Indices auflisten

 

Excel Alle Passwörter ändern in einem Verzeichnis

Excel Alle Zeilen und Spalten Einblenden

 

Excel Alle Zellen Eines Bereiches Durchlaufen

Excel Anwendung externer Datei starten

 

Excel Anzahl im Blatt gebrauchter Reihen

 

Excel Anzahl im Blatt gebrauchter Spalten

 

Excel Anzahl selectierter Zellen nur 1 dann Messagebox

Excel einfacher kopieren

 

Excel Einfügen von Tabellenblättern verhindern

Excel Monate umrechnen

 

Excel Msgbox Demo

 

Excel Msgbox spezial

 

Excel Namensliste Nach Nächstem Buchstaben Leerzeile einfügen

Excel Nicht Gesperrte Zellen Einfärben + Löschen für Eingabe

Excel Nur Nummern kann man bearbeiten

 

Excel Nur Zelleninhalt löschen

 

Excel Objekete auslesen 1 (For 1 to ...)

 

Excel Objekete auslesen 2 (For each ...)

 

Excel Objekete hinzufügen

 

Excel Objekete rotieren lassen

 

Excel Offene Arbeitsmappen in einer Messagebox anzeigen

Excel Öffnen einer Datei

 

Excel Prüfen ob eine Datei schon geöffnet ist

 

Excel Rahmenart und Farbe bestimmen

 

Excel Rechnung Nummerieren

 

Excel Registry Einträge schreiben und lesen

 

Excel Registry Startdatum schreiben und lesen und benützen

Excel Rundenzähler

 

 

 

Excel 2002 Registerkarten Färben

Public Sub RegisterkarteFaerben()

 

    If Application.Version < 10 Then     '<> "10.0" Then   funktioniert auch, aber die vordere ist besser, wegen späterer höherer Nummern !

 

    MsgBox "Sie können dieses VBA Makro leider nur ab" _

 

    & Chr(13) & "Excel Version 10.0 (Excel XP) laufen lassen !", _

 

    , "               Falsche Excel Version   ! ! !"

 

    Exit Sub

 

    End If

 

ActiveWorkbook.ActiveSheet.Tab.ColorIndex = 5     '3=Rot , 5=Blau

 

'Excel 2000 = Version  9.0

 

'Excel XP   = Version 10.0

 

End Sub

Excel Active Workbook etc. abfragen

Public Sub Files_etc()

 

Debug.Print ActiveCell.Address                   'Zellen Adresse

 

Debug.Print ActiveCell                               'Zellenwert

 

Debug.Print ActiveSheet.Name                   'Tabelle

 

Debug.Print ActiveWorkbook.Name           'Mappe

 

Debug.Print ActivePrinter                            'Drucker

 

End Sub

Excel addieren anhand der Farbe der Fonts

Sub CountIfColor()

 

Dim TB As Worksheet

 

Dim iRange As Range, c As Range

 

Dim yRed As Double, yBlue As Double, yGreen As Double

 

    Set TB = Worksheets(1)

 

    Set iRange = TB.Range("A1:F100")

 

    yRed = 0: yBlue = 0: yGreen = 0

 

    For Each c In iRange.Cells

 

        Select Case c.Font.ColorIndex

 

            Case Is = 3: yRed = yRed + c

 

            Case Is = 5: yBlue = yBlue + c

 

            Case Is = 4: yGreen = yGreen + c

 

        End Select

 

    Next c

 

    TB.[g1] = yRed: TB.[g2] = yBlue: TB.[g3] = yGreen

 

    TB.[f1] = "Rot": TB.[f2] = "Blau": TB.[f3] = "Grün"

 

End Sub

Excel Adressen suchen über eine Userform

Private Sub CommandButton1_Click()

 

    UserForm2.Hide

 

CommandButton3_Click

 

End Sub

 

'***************************************************

 

Private Sub CommandButton2_Click()

 

Set frm2 = UserForm2

 

    With frm2

 

    Sheets("Adressen").Select

 

    Range("a:a").Select

 

    On Error GoTo fehler

 

    Selection.Find(what:=.TextBox1.Value, _

 

    after:=ActiveCell, _

 

    LookIn:=xlFormulas, lookat:=xlWhole, _

 

    searchorder:=xlByRows, searchdirection:=xlNext, _

 

    MatchCase:=False).Activate

 

    .TextBox1.Value = ActiveCell.Value

 

    .TextBox2.Value = ActiveCell.Offset(0, 1).Value

 

    .TextBox3.Value = ActiveCell.Offset(0, 2).Value

 

    .TextBox4.Value = ActiveCell.Offset(0, 3).Value

 

    .TextBox5.Value = ActiveCell.Offset(0, 4).Value

 

    .TextBox6.Value = ActiveCell.Offset(0, 5).Value

 

    .TextBox7.Value = ActiveCell.Offset(0, 6).Value

 

    .TextBox8.Value = ActiveCell.Offset(0, 7).Value

 

    .TextBox9.Value = ActiveCell.Offset(0, 8).Value

 

    .TextBox10.Value = ActiveCell.Offset(0, 9).Value

 

    Range("a2").Select

 

    Exit Sub

 

fehler:

 

    MsgBox "Die Person: " & .TextBox1.Value & " konnte nicht gefunden werden !"

 

    Range("a2").Select

 

    End With

 

End Sub

 

***************************************************

 

Private Sub CommandButton3_Click()

 

    Dim tb As Object

 

    For Each tb In UserForm2.Controls

 

        If TypeName(tb) = "TextBox" Then tb.Text = ""

 

    Next tb

 

End Sub

Excel Adressen über eine Userform erfassen

Private Sub CommandButton1_Click()

 

    UserForm1.Hide

 

End Sub

 

'***************************************************

 

Private Sub CommandButton2_Click()

 

Set frm = UserForm1

 

    Sheets("Adressen").Activate

 

    Range("a65536").End(xlUp).Offset(1, 0).Select

 

    With frm

 

    ActiveCell.Value = .TextBox1.Value

 

    ActiveCell.Offset(0, 1).Value = .TextBox2.Value

 

    ActiveCell.Offset(0, 2).Value = .TextBox3.Value

 

    ActiveCell.Offset(0, 3).Value = .TextBox4.Value

 

    ActiveCell.Offset(0, 4).Value = .TextBox5.Value

 

    ActiveCell.Offset(0, 5).Value = .TextBox6.Value

 

    ActiveCell.Offset(0, 6).Value = .TextBox7.Value

 

    ActiveCell.Offset(0, 7).Value = .TextBox8.Value

 

    ActiveCell.Offset(0, 8).Value = .TextBox9.Value

 

    ActiveCell.Offset(0, 9).Value = .TextBox10.Value

 

    End With

 

Columns("a:j").EntireColumn.AutoFit               'Kolonnen Auto fiten

 

CommandButton3_Click                                     'Felder löschen

 

End Sub

 

'***************************************************

 

Private Sub CommandButton3_Click()

 

    Dim tb As Object

 

    For Each tb In UserForm1.Controls

 

        If TypeName(tb) = "TextBox" Then tb.Text = ""

 

    Next tb

 

End Sub

Excel Alle anderen geöffneten Dateien werden gespeichert und unbemerkt geschlossen

Sub Schließen_anderer_Dateien()

 

    Application.DisplayAlerts = False

 

    Application.ScreenUpdating = False

 

    Dim WB

 

     If Workbooks.Count > 1 Then

 

         For Each WB In Application.Workbooks

 

               If WB.Name <> ActiveWorkbook.Name Then

 

                   WB.Save

 

                   WB.Close

 

               End If

 

          Next

 

     End If

 

End Sub

Excel Alle Blattnamen in einer Messagebox anzeigen

Sub Blattnamen_anzeigen()

 

   Dim Count, Tabs

 

     Tabs = "Anzahl Blätter:  " & Sheets.Count & Chr$(13)

 

        For Count = 1 To Sheets.Count

 

            Tabs = Tabs & Chr$(13) & "Blatt " & Count & ": " & Sheets(Count).Name

 

        Next

 

   MsgBox Tabs, vbOKOnly + vbInformation, "Diese Datei enthält die Blätter:"

 

End Sub

Excel Alle Ereignisse abschalten (z.b. Makro "Worksheet_Change" temporär ausschalten)

Mit

 

Application.EnableEvents=False

 

kann man ALLE Ereignisse abschalten.

 

Achtung:

 

Muß unbedingt wieder mit

 

Application.EnableEvents=true

 

eingeschaltet werden, wenn nicht mehr benötigt, sonst keine Speicherabfrage bei Schliessung usw.

Excel Alle Farb Indices auflisten

Sub FarbIndices()

 

   Dim intCounter As Integer

 

   Workbooks.Add

 

   For intCounter = 1 To 56

 

      Cells(intCounter, 1).Interior.ColorIndex = intCounter

 

      Cells(intCounter, 2) = intCounter

 

   Next intCounter

 

End Sub

Excel Alle Passwörter ändern in einem Verzeichnis

Public Sub PasswoerterAendern()

 

Dim Datei As String

 

 

 

Datei = Dir("C:\1\*.xls")

 

 

 

While Datei <> ""

 

ChDrive "C:\"

 

ChDir "C:\1\"

 

On Error Resume Next

 

Workbooks.Open Datei

 

ActiveSheet.Unprotect Password:="Altes Passwort"

 

ActiveSheet.Protect Password:="Neues Passwort", _

 

DrawingObjects:=True, Contents:=True, Scenarios:=True

 

ActiveWorkbook.Close Savechanges:=xlSaveChanges

 

Datei = Dir()

 

Wend

 

End Sub

Excel Alle Zeilen und Spalten Einblenden

Public Sub AllesEinblenden()

 

Cells.Select

 

Selection.EntireColumn.Hidden = False

 

Selection.EntireRow.Hidden = False

 

End Sub

Excel Alle Zellen Eines Bereiches Durchlaufen

Public Sub AlleZellenEinesBereichesDurchlaufen()

 

Dim Zeile As Integer

 

Dim Spalte As Integer

 

Dim Zelle As Range

 

   

 

    For Zeile = 1 To 4

 

        For Spalte = 2 To 3

 

        Set Zelle = Cells(Zeile, Spalte)

 

        Zelle.Interior.ColorIndex = 5

 

        Next

 

    Next

 

End Sub

Excel Anwendung externer Datei starten

Link:  "C:\Daten\Office Supporter\VBA Programmieren\Excel\Anwendung starten von wer.wer"

 

Sub Anwendung_starten_von_wer_FastCalculation()

 

' Anwendung starten von wer.wer

 

Workbooks.Open ThisWorkbook.Path & "\wer.wer"

 

Application.Run "wer.wer!System_FastCalculation"

 

End Sub

Excel Anzahl im Blatt gebrauchter Reihen

Public Sub AnzahlImBlattGebrauchterReihen()

 

MsgBox ActiveSheet.UsedRange.Rows.Count

 

End Sub

Excel Anzahl im Blatt gebrauchter Spalten

Public Sub AnzahlImBlattGebrauchterSpalten()

 

MsgBox ActiveSheet.UsedRange.Columns.Count

 

End Sub

Excel Anzahl selectierter Zellen nur 1 dann Messagebox

If Selection.Count < 2 Then MsgBox "Bitte einen Bereich wählen !", vbInformation, "ACHTUNG"

Excel einfacher kopieren

Range("A1").Copy Range("F30")

 

 

 

Ist gleichbedeutend wie:

 

Range("A1").Select

 

Selection.Copy

 

Range("F30").Select

 

ActiveSheet.Paste

Excel Einfügen von Tabellenblättern verhindern

Private Sub Workbook_NewSheet(ByVal Sh As Object)

 

Application.DisplayAlerts = False                 'Warnmeldung nicht anzeigen

 

Sh.Delete

 

Application.DisplayAlerts = True                  'Warnmeldung wieder anzeigen

 

End Sub

Excel Monate umrechnen

Select Case Monat

 

    Case "Januar":      Monat = 1

 

    Case "Februar":     Monat = 2

 

    Case "März":        Monat = 3

 

    Case "April":       Monat = 4

 

    Case "Mai":         Monat = 5

 

    Case "Juni":        Monat = 6

 

    Case "Juli":        Monat = 7

 

    Case "August":      Monat = 8

 

    Case "September":   Monat = 9

 

    Case "Oktober":     Monat = 10

 

    Case "November":    Monat = 11

 

    Case "Dezember":    Monat = 12

 

                        GoTo Fehler

 

End Select

 

 

 

Select Case Monat

 

    Case 1: Monat = "Januar"

 

    Case 2: Monat = "Februar"

 

    Case 3: Monat = "März"

 

    Case 4: Monat = "April"

 

    Case 5: Monat = "Mai"

 

    Case 6: Monat = "Juni"

 

    Case 7: Monat = "Juli"

 

    Case 8: Monat = "August"

 

    Case 9: Monat = "September"

 

    Case 10: Monat = "Oktober"

 

    Case 11: Monat = "November"

 

    Case 12: Monat = "Dezember"

 

End Select

Excel Msgbox Demo

Sub msgboxdemo()

 

LIne1 = "This is line 1" & vbCrLf

 

line2 = "this is line 2" & vbCrLf

 

TheStyle = vbInformation + vbYesNoCancel

 

Msg = LIne1 & line2

 

Title = "Msg Demo"

 

again:

 

response = MsgBox(Msg, TheStyle, Title)

 

 

 

Select Case response

 

Case vbYes: MsgBox ("You clicked Yes")

 

Case vbNo: MsgBox ("You clicked No")

 

Case vbCancel: Exit Sub

 

End Select

 

GoTo again

 

End Sub

Excel Msgbox spezial

Link: Messagebox für Excel

Excel Namensliste Nach Nächstem Buchstaben Leerzeile einfügen

Sub ZeilenEinfügen()

 

'Es wird nach jedem neuen Buchstaben eine Leerzeile eingefügt

 

Dim i As Integer

 

 

 

Sheets(1).Activate

 

Range("A2").Select

 

For i = 1 To ActiveSheet.UsedRange.Rows.Count

 

    If LCase(Left(ActiveCell.Value, 1)) <> _

 

    LCase(Left(ActiveCell.Offset(-1, 0).Value, 1)) Then

 

    ActiveCell.EntireRow.Insert           'Eine Zeile wird eingefügt

 

    ActiveCell.Offset(2, 0).Select

 

    Else

 

    ActiveCell.Offset(1, 0).Select

 

    End If

 

Next i

 

End Sub

 

'**********************************************************************

 

Sub ZeilenLöschen()

 

Dim i As Integer

 

 

 

Sheets(1).Activate

 

Range("A2").Select

 

For i = 1 To ActiveSheet.UsedRange.Rows.Count

 

 If IsEmpty(ActiveCell.Value) Then

 

  ActiveCell.EntireRow.Delete

 

 Else

 

 ActiveCell.Offset(1, 0).Select

 

 End If

 

Next i

 

End Sub

Excel Nicht Gesperrte Zellen Einfärben + Löschen für Eingabe

Public Sub Nicht_Gesperrte_Zellen_Einfaerben()

 

Call ChkFile

 

Zelle = ActiveCell.Address

 

Call SchutzDeaktivieren

 

 

 

    For Each c In ActiveSheet.UsedRange

 

        If c.Locked = False Then

 

            c.Interior.ColorIndex = 40  ' -4142 ' Ohne Zellenfarbe

 

            c.Value = ""

 

        End If

 

    Next c

 

 

 

Range(Zelle).Select

 

Call SchutzAktivieren

 

End Sub

Excel Nur Nummern kann man bearbeiten

Sub Set_Protection()

 

' Man kann nur Nummern welche zusätzlich blau eingefärbt werden bearbeiten.

 

' Alle Anderen Zellen werden gesperrt.

 

On Error GoTo errorHandler

 

Dim myDoc As Worksheet

 

Dim cel As Range

 

Set myDoc = ActiveSheet

 

myDoc.Unprotect

 

For Each cel In myDoc.UsedRange

 

    If Not cel.HasFormula And Not TypeName(cel.Value) = "Date" And Application.IsNumber(cel) Then

 

        cel.Locked = False

 

        cel.Font.ColorIndex = 5    ' Font Blau einfärben

 

    Else

 

        cel.Locked = True

 

        cel.Font.ColorIndex = xlColorIndexAutomatic

 

    End If

 

Next

 

myDoc.Protect

 

Exit Sub

 

errorHandler:

 

MsgBox Error

 

End Sub

Excel Nur Zelleninhalt löschen

Sub LöschenMitAbfrage()

 

Dim Bereich As Range

 

On Error Resume Next

 

Set Bereich = Application.InputBox("Bereich auswählen, den Sie löschen wollen ", Type:=8)

 

Bereich.Activate

 

Selection.ClearContents                    'Selection Löschen Nur Zelleninhalt

 

Range(ActiveCell.Address).Select    'Erste Zelle des Bereichs auswählen

 

End Sub

Excel Objekete auslesen 1 (For 1 to ...)

Public Sub ObjekteAuslesen()

 

Tabelle = 1          'Tabellen-Nummer veränderbar

 

Worksheets(Tabelle).Select

 

    For i = 1 To ActiveSheet.Shapes.Count

 

    Objekte = Objekte & Chr$(13) & Sheets(Tabelle).Shapes(i).Name

 

    Next i

 

    MsgBox Objekte, vbInformation, "Diese Tabelle enthält " & ActiveSheet.Shapes.Count & " Objekte"

 

End Sub

Excel Objekete auslesen 2 (For each ...)

Public Sub ObjekteAuslesen()

 

Dim SH As Shape

 

Tabelle = 1          'Tabellen-Nummer veränderbar

 

Worksheets(Tabelle).Select

 

    For Each SH In ActiveSheet.Shapes

 

    Objekte = Objekte & Chr$(13) & SH.Name

 

    Next SH

 

    MsgBox Objekte, vbInformation, "Diese Tabelle enthält " & ActiveSheet.Shapes.Count & " Objekte"

 

End Sub

Excel Objekete hinzufügen

Jeder Form wird ein Standardname zugewiesen, wenn Sie sie der Shapes-Auflistung hinzufügen. Wenn Sie der Form einen aussagekräftigeren Namen geben möchten, verwenden Sie die Name-Eigenschaft. Im folgenden Beispiel wird in myDocument ein Rechteck eingefügt. Ihm werden der Name "Red Square" sowie Vordergundfarbe und Linienart zugewiesen.

 

 

 

Public Sub ObjektEinfuegen()

 

Set myDocument = Worksheets(1)

 

With myDocument.Shapes.AddShape(msoShapeRectangle, 144, 144, 72, 72)

 

    .Name = "Red Square"

 

    .Fill.ForeColor.RGB = RGB(255, 0, 0)

 

    .Line.DashStyle = msoLineDashDot

 

End With

 

End Sub

Excel Objekete rotieren lassen

Sub ObjektRotieren()

 

Dim obj As Shape

 

Set obj = Sheets(1).Shapes(1)

 

For i = 1 To 180 Step 20

 

 obj.Rotation = i

 

Application.Wait Now + TimeSerial(0, 0, 1) 'Pause

 

Next i

 

End Sub

Excel Offene Arbeitsmappen in einer Messagebox anzeigen

Sub Dateinamen_anzeigen()

 

   Dim Count%, Dat$

 

     Dat = "Anzahl geöffneter Arbeitsmappen:  " & Workbooks.Count & Chr$(13)

 

         For Count = 1 To Workbooks.Count

 

           Dat = Dat & Chr$(13) & "Datei " & Count & ": " & Workbooks(Count).Name

 

         Next

 

     MsgBox Dat, vbOKOnly + vbInformation, "Folgende Dateien sind geöffnet:"

 

End Sub

Excel Öffnen einer Datei

Sub Öffnen_Miete()

 

    ChDir "C:\Daten\Excel\Privat\Miete"

 

    Workbooks.Open Filename:="C:\Daten\Excel\Privat\Miete\Miete.xls"

 

    Call Öffnen_Leer

 

End Sub

 

 

 

Sub Öffnen_Leer()

 

    ChDir "C:\Daten\Excel\Buero\2004"

 

End Sub

Excel Prüfen ob eine Datei schon geöffnet ist

Public Sub TestePfad()

 

    Dim sPfad As String

 

    sPfad = "C:\Daten\Excel\Reto.xls" ' Pfad ändern für Tests

 

    MsgBox DateiGeoeffnet(sPfad)

 

End Sub

 

   

 

Private Function DateiGeoeffnet(DerPfad As String) As Boolean

 

    On Error Resume Next

 

    Open DerPfad For Binary Access Read Lock Read As #1

 

    Close #1

 

    If Err.Number <> 0 Then

 

        DateiGeoeffnet = True

 

        Err.Clear

 

    End If

 

End Function

Excel Rahmenart und Farbe bestimmen

Public Sub RahmenFestlegen()

 

Range("a5:c10").Select

 

    With Selection.Borders

 

        .ColorIndex = 5

 

        .LineStyle = xlDot

 

    End With

 

End Sub

 

 

 

xlContinuous         > Durchgezogene Linie

 

xlDash                   > Gestrichelte Linie

 

xlDashDot             > Linie aus Strichen und Punkten

 

xlDashDotDot       > Linie aus Strich-Punkt-Punkt

 

xlDot                     > Gepunktete Linie

 

xlDouble               > Linie doppelt

 

xlSlantDashDot     > Linie aus Wellenzeichen und Punkt

 

xlLineStyleNone   > Keine Linie

Excel Rechnung Nummerieren

Public Sub Nummerieren()

 

      'Unterstrichen Zellen in der Spalte B werden nicht berücksichtigt

 

10    Range("A24").Select

 

20    Do

 

30    Selection.ClearContents

 

40    ActiveCell.Offset(1, 0).Select

 

50    Loop Until ActiveCell.Value = 999

 

 

 

60    Range("B24").Select

 

 

 

70    I = 1

 

80    Do

 

90        If ActiveCell.Font.Underline = xlUnderlineStyleSingle = True Then

 

100       ActiveCell.Offset(1, 0).Select

 

          GoTo 90

 

110       End If

 

         

 

120       Select Case ActiveCell.Value

 

             

 

          Case "":        ActiveCell.Offset(1, 0).Select

 

130                       I = I - 1

 

140       Case Else:      ActiveCell.Offset(0, -1).Select

 

150                       ActiveCell.Value = I

 

160                       ActiveCell.Offset(0, 1).Select

 

170                       ActiveCell.Offset(1, 0).Select

 

180       End Select

 

190       I = I + 1

 

200   Loop Until ActiveCell.Offset(0, -1).Value = 999

 

210   ActiveCell.Offset(0, -1).Select

 

End Sub

Excel Registry Einträge schreiben und lesen

' Const für Registry Einträge

 

Const Application_Name As String = "RZ Utilities"

 

Const Section_Name As String = "RZ Utilities - MWST Rechner"

 

 

 

Private Sub UserForm_Initialize()

 

' Wenn kein Registry Eintrag vorhanden ist dann einen erstellen

 

If GetSetting(Application_Name, Section_Name, "MWST Satz") = "" Then

 

    SaveSetting Application_Name, Section_Name, "MWST Satz", "7.60"

 

End If

 

txtMWST.Text = GetSetting(Application_Name, Section_Name, "MWST Satz")

 

End Sub

 

 

 

Private Sub cmdLoeschen_Click()

 

txtBrutto.Text = ""

 

txtRabatt.Text = ""

 

txtSkonto.Text = ""

 

txtMWST.Text = ""

 

txtMWST.Text = GetSetting(Application_Name, Section_Name, "MWST Satz")

 

txtNetto.Text = ""

 

txtBrutto.SetFocus

 

End Sub

Excel Registry Startdatum schreiben und lesen und benützen

' Const für Registry Einträge

 

Const Application_Name As String = "RZ Utilities"

 

Const Section_Name As String = "RZ Utilities - Application"

 

 

 

' Wenn kein Registry Eintrag vorhanden ist dann einen erstellen (Datum für 1. Start)

 

If GetSetting(Application_Name, Section_Name, "Startdatum") = "" Then

 

    SaveSetting Application_Name, Section_Name, "Startdatum", Date

 

End If

 

 

 

' Benüzungsdauer

 

Startdatum = Format(GetSetting(Application_Name, Section_Name, "Startdatum"), 0)

 

Heute = Format(Date, 0)

 

AnzahlTage = Heute - Startdatum

 

MsgBox "Sie benützen diese Programm bereits " & AnzahlTage & " Tage !", vbInformation, AT & "  -  S h a r e w a r e"

 

' If AnzahlTage > 30 Then Call Ende  ' 30 Tage Nutzungsdauer

Excel Rundenzähler

Private Sub Worksheet_Change(ByVal Target As Range)

 

If Target.Address = "$E$1" Then

 

Call runden 'Aufruf des Makros 'runden'

 

Range("E1").Select

 

End If

 

End Sub

 

 

 

Sub runden()

 

Application.EnableEvents = False

 

Dim Name As String

 

Dim zeile As Long

 

Name = [e1]

 

On Error GoTo Fehler

 

zeile = Columns("a:a").Find(What:=Name, LookIn:=xlValues).Row

 

If Name <> "" Then

 

    Cells(zeile, 2) = Cells(zeile, 2) + 1

 

    Range("A1").Sort Key1:=Range("B2"), Order1:=xlDescending, Key2:=Range("A2") _

 

    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _

 

    False, Orientation:=xlTopToBottom

 

    [e1].ClearContents

 

    Application.EnableEvents = True

 

    Exit Sub

 

End If

 

 

 

Fehler:

 

MsgBox ("Startnummer " & Name & " nicht vorhanden")

 

[e1].ClearContents

 

Application.EnableEvents = True

 

End Sub