Software für Sie.

Zuerst wird das Blatt mit dem Namen des aktuellen Monats aktiviert, dann auf dem gesamten Blatt nach dem Datum gesucht:

Dim rngZelle As Range Sheets(Format(Date, "MMMM")).Select Set rngZelle = Cells.Find(What:=Date, LookAt:=xlWhole, LookIn:=xlValues) If Not rngZelle Is Nothing Then rngZelle.Activate

U. U. wäre es noch sinnvoll, Fehler abzufangen - wenn z. B. das Blatt nicht existiert.

Application-Ereignisse gelten für die gesamte Anwendung, für alle Fenster, Arbeitsmappen und Tabellenblätter. Um mit Ereignissen des Application-Objekts zu arbeiten, mu� man zuvor eine öffentliche Variable der Objektklasse in einem Klassenmodul definieren und danach ein Objekt der neuen Klasse und darin wieder ein Objekt der Klasse. Letzteres wird wiederum in einem einfachen Modul erstellt.

Was sich zunächst ein wenig kompliziert anhört, ist im Grunde recht einfach zu verwirklichen.

Ab sofort können alle Ereignisse des Application-Objektes empfangen werden, wenn diese Routine ausgeführt wurde. Damit das neue Objekt immer zur Verfügung steht, sollte der letzte Code in Workbook_Open() der Mappe.

Wir können nun zum Besipiel jeden Blattwechsel in jeder offenen Mappe abfangen (also nicht nur in der mit dem Code), indem wir in das Klassenmodul eintragen:

Private Sub Anwendung_SheetActivate(ByVal Sh As Object) MsgBox Sh.Name End Sub

Hinweis:
Um Application-Ereignisse zu deaktivieren, setzt man einfach den Verweis auf das "Anwendungsobjekt" auf Nothing, also Set Anwendungsobjekt.Anwendung = Nothing

Parameter:

Die Application-Ereignisse haben feste Parameter, die mit übergeben werden (im vorigen Code-Beispiel ist das schon an ByVal Sh As Object zu sehen):

Ereignisse:

Am einfachsten wählt man die natürlich über das Dropdown im Klassenmodul, wie es in der obigen Abbildung dargestellt ist. Hier eine kleine �bersicht:

Anwendung_NewWorkbook(ByVal Wb As Excel.Workbook)

Eine neue Arbeitsmappe wurde eingefügt.

Anwendung_SheetActivate(ByVal Sh As Object)

Ein anderes Blatt wurde aktiviert (Blattwechsel).

Anwendung_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

Doppelklick wurde ausgeführt.

Anwendung_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Excel.Range, Cancel As Boolean)

Klick mit der rechten Maustaste.

Anwendung_SheetCalculate(ByVal Sh As Object)

Neuberechnung eines Tabellenblattes.

Anwendung_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range)

Zelleninhalt eines Tabellenblattes wurde verändert.

Anwendung_SheetDeactivate(ByVal Sh As Object)

Ein Tabellenblatt wurde verlassen (Blattwechsel).

Anwendung_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range)

Zellenmarkierung eines Tabellenblattes wurde geändert.

Anwendung_WindowActivate(ByVal Wb As Excel.Workbook, ByVal Wn As Excel.Window)

Ein neues Fenster wurde aktiviert (Fensterwechsel).

Anwendung_WindowDeactivate(ByVal Wb As Excel.Workbook, ByVal Wn As Excel.Window)

Ein Fenster wurde verlassen (Fensterwechsel).

Anwendung_WindowResize(ByVal Wb As Excel.Workbook, ByVal Wn As Excel.Window)

Die Grö�e eines Fensters wurde verändert.

Anwendung_WorkbookActivate(ByVal Wb As Excel.Workbook)

Eine neue Arbeitsmappe wurde aktiviert (Arbeitsmappenwechsel).

Anwendung_WorkbookAddinInstall(ByVal Wb As Excel.Workbook)

Eine Arbeitsmappe wurde als Add-In installiert.

Anwendung_WorkbookAddinUninstall(ByVal Wb As Excel.Workbook)

Eine Arbeitsmappe wurde als Add-In deinstalliert.

Anwendung_WorkbookBeforeClose(ByVal Wb As Excel.Workbook, Cancel As Boolean)

Eine Arbeitsmappe soll geschlossen werden.

Anwendung_WorkbookBeforePrint(ByVal Wb As Excel.Workbook, Cancel As Boolean)

Eine Arbeitsmappe soll ausgedruckt werden.

Anwendung_WorkbookBeforeSave(ByVal Wb As Excel.Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)

Eine Arbeitsmappe soll geschlossen werden.

Anwendung_WorkbookDeactivate(ByVal Wb As Excel.Workbook)

Eine Arbeitsmappe wurde verlassen (Arbeitsmappenwechsel).

Anwendung_WorkbookNewSheet(ByVal Wb As Excel.Workbook, ByVal Sh As Object)

In einer Arbeitsmappe wurde ein neues Tabellenblatt eingefügt.

Anwendung_WorkbookOpen(ByVal Wb As Excel.Workbook)

Eine neue Arbeitsmappe wurde geöffnet.

Ab Excel 365

Zunächst muss das Blatt mit dem Monatsnamen des aktuellen Datums ermittelt werden. Das geht mit Indirekt:

=INDIREKT(TEXT(HEUTE();"MMMM")&"!A1:AE1")

Diese Formel liefert die komplette erste Zeile mit den Datumsangaben des aktuellen Monats. Sie kann nun in der Funktion FILTER() als Suchbereich verwendet werden. Damit können alle Mitarbeiter des Tages ermittelt werden (hier bis Zeile 30):

=FILTER(INDIREKT(TEXT(HEUTE();"MMMM")&"!A2:AE30");INDIREKT(TEXT(HEUTE();"MMMM")&"!A1:AE1")=HEUTE())

Die Formel gibt aus der Datumsspalte alle Einträge zurück, die bis Zeile 30 liegen.

Da aber mehr Zeilen (wie hier bis 30) verwendet werden müssen (die maximale Anwesenheit muss ja berücksichtigt werden), liefert diese Formel für die leeren Zellen, in denen also kein Mitarbeiter eingetragen ist, jeweils eine 0. Das kann also weder mit ANZAHL() noch mit ANZAHL2() gezählt werden, da sonst die 0 immer einflie�en würde.

Wir verwenden im Beispiel SUMME(Wenn( und lassen die Einträge zählen, die <> 0 sind:

=SUMME(WENN(FILTER(INDIREKT(TEXT(HEUTE();"MMMM")&"!A2:AE30");INDIREKT(TEXT(HEUTE();"MMMM")&"!A1:AE1")=HEUTE())<>0;1;0))

Ã?ltere Versionen

Hier ist die Formel etwas länger:

=ANZAHL2(INDIREKT(TEXT(HEUTE();"MMMM")&"!"&LINKS(ADRESSE(1;VERGLEICH(HEUTE();INDIREKT(TEXT(HEUTE();"MMMM")&"!1:1"));4);1+(VERGLEICH(HEUTE();INDIREKT(TEXT(HEUTE();"MMMM")&"!1:1"))>26))&"2:"&LINKS(ADRESSE(1;VERGLEICH(HEUTE();INDIREKT(TEXT(HEUTE();"MMMM")&"!1:1"));4);1+(VERGLEICH(HEUTE();INDIREKT(TEXT(HEUTE();"MMMM")&"!1:1"))>26))&"1000"))

Das Add-In fragt zunächst nach dem Ordner, in den die einzelnen Dateien gespeichert werden sollen. Dann werden die einzelnen Blätter unter deren Namen mit der Endung xlsx (kann im Code geändert werden) gespeichert, wobei geprüft wird, ob eine Datei mit diesem Namen im Ordner bereits existiert. Zum Anschluss kommt eine Erfolgsmeldung oder die Information, welche Blätter nicht gespeichert werden konnten.

Der Aufruf erfolgt im Menüband im Ribbon JL-Dateien erstellen.

Download: blaetter_speichern.xlam

• Menüband Entwicklertools einblenden (Rechtsklick in leere Stelle des Menübands und Menüband anpassen)
• Einfügen ▸ ActiveX-Steuerelemente ▸ Kombinationsfeld
• Kombinationsfeld zeichnen
• Doppelklick auf das Feld, dadurch wird der VBA-Editor geöffnet
• folgenden Code eingeben (Zelle anpassen):

Private Sub ComboBox1_Change() Range("A1") = ComboBox1.Text End Sub[/vbacode]

• Menü Einfügen - Modul
• folgendes Makro eingeben (dient zum Füllen des Kombinationsfeldes):

Sub Fuellen() Dim intI As Integer Sheets("Tabelle1").ComboBox1.Clear For intI = 1 To Sheets.Count Sheets("Tabelle1").ComboBox1.AddItem (Sheets(intI).Name) Next End Sub

Durch den Aufruf des Makros Fuellen wird das Kombinationsfeld gefüllt; nach der Auswahl eines Blattes erscheint dessen Name im Beispiel in A1.

Zum Sortieren der Blätter gibt es verschiedene Möglichkeiten, was auch etwas von den Rahmenbedingungen abhängig ist. Was soll zum Beispiel mit Blättern passieren, deren Namen nicht der Syntax der zu sortierenden Blattnamen entsprechen? Hier sind drei Beispiele, die ggf. noch angepasst werden müssen.

In dem Fall werden unterwegs (also nicht am Anfang) Blätter mit Namen, die nicht der Syntax entsprechen, nach hinten verschoben - ansonsten wird so lange sortiert, bis die Zahl im folgenden Blattnamen nicht mehr gö�er ist:

Sub BlaetterSortieren() Dim bolSortiert As Boolean Dim intBlatt As Integer, intBlatt1 As Integer Dim varAkt, varNaechst bolSortiert = False Do While bolSortiert = False bolSortiert = True For intBlatt = 1 To Sheets.Count varAkt = Replace(Sheets(intBlatt).Name, "Tab", "") If IsNumeric(varAkt) Then For intBlatt1 = intBlatt To Sheets.Count varNaechst = Replace(Sheets(intBlatt1).Name, "Tab", "") If IsNumeric(varNaechst) Then If varNaechst * 1 < varAkt * 1 Then Sheets(intBlatt1).Move Before:=Sheets(intBlatt) bolSortiert = False End If Else Sheets(intBlatt1).Move after:=Sheets(Sheets.Count) End If Next End If Next Loop End Sub

Ein Beispiel mit Sprungmarken, Reihenfolge Tab1, Tab2, Tab11:

Sub Blattsort() Dim intAnzahl As Integer, intN As Integer, intM As Integer, intI As Integer, intZahlM As Integer, intZahlN As Integer Dim WS As Worksheet intAnzahl = ActiveWorkbook.Worksheets.Count For intM = 1 To intAnzahl For intN = intM To intAnzahl On Error Resume Next For intI = 1 To Len(Worksheets(intN).Name) If IsNumeric(Right(Worksheets(intN).Name, intI)) = False Then intI = intI - 1 If intI = 0 Then GoTo TEXT intZahlN = Right(Worksheets(intN).Name, intI) Exit For End If Next intI For intI = 1 To Len(Worksheets(intM).Name) If IsNumeric(Right(Worksheets(intM).Name, intI)) = False Then intI = intI - 1 If intI = 0 Then GoTo TEXT intZahlM = Right(Worksheets(intM).Name, intI) Exit For End If Next intI If CInt(intZahlN) < CInt(intZahlM) Then Worksheets(intN).Move Before:=Worksheets(intM) GoTo NAECHSTE TEXT: If Worksheets(intN).Name < Worksheets(intM).Name Then Worksheets(intN).Move Before:=Worksheets(intM) NAECHSTE: Next intN Next intM MsgBox "Anzahl der Tabellen: " & intAnzahl End Sub

Ein kurzes Beispiel, aber die Reihenfolge ist Tab1, Tab11, Tab2:

Sub Blattsort1() Dim intX As Integer Dim bolY As Boolean Do bolY = True For intX = 1 To Sheets.Count - 1 If Sheets(intX).Name > Sheets(intX + 1).Name Then Sheets(intX + 1).Move Before:=Sheets(intX) bolY = False End If Next intX Loop Until bolY = True End Sub

Der Code löscht zunächst das Blatt Zusammenfassung, falls es existiert. Alternativ können natürlich auch Zellen oder Zellinhalte dieses Blattes gelöscht werden.

Anschlie�end läuft im Beispiel eine Schleife über die ersten drei Tabellenblätter. Von denen werden die Zellen in den Spalten 1 bis 5 bis zur letzten (in Spalte 1) ausgefüllten Zeile genommen und untereinander auf das Blatt Zusammenfassung kopiert.

Sub speichern() Dim lngZeile As Long, lngLetzteZ As Long, bytI As Byte Dim strBereich As String On Error Resume Next Worksheets("Zusammenfassung").Delete 'Auswertungsblatt löschen On Error GoTo 0: Err.Clear Worksheets.Add after:=Sheets(Sheets.Count) 'Auswertungsblatt einfügen ActiveSheet.Name = "Zusammenfassung" 'Variable, die dafür sorgt, da� die zusammengefa�ten Daten untereinander stehen lngZeile = 1 'hier ab Zeile 1 For bytI = 1 To 3 'Von Blatt 1 bis Blatt 3 zusammenfassen lngLetzteZ = Worksheets(bytI).Cells(Worksheets(bytI).Rows.Count, 1).End(xlUp).Row strBereich = Range(Cells(1, 1), Cells(lngLetzteZ, 5)).Address 'Datenbereich (hier bis Spalte 5) auswählen Worksheets(bytI).Range(strBereich).Copy Sheets("Zusammenfassung").Cells(lngZeile, 1) 'Variable Zeile erhöhen lngZeile = lngZeile + lngLetzteZ Next End Sub

Dafür gibt es verschiedene Möglichkeiten - wobei es mit der Find-Methode Probleme gibt, da die nach dem Datum sucht, nicht aber nach einem Teil davon. Gezeigt werden zwei Möglichkeiten - die erste funktioniert ab Excel 365, die zweite generell:

Einsatz der Tabellenfunktion FILTER() ab Excel 365

Das grundlegende Vorgehen ist hier wie bei der älteren Variante (siehe unten), nur beim Sammeln der Daten wird die Tabellenblattfunktion FILTER() verwendet. Die Blätter werden also auch einzeln abgearbeitet, pro Blatt arbeitet aber diese Funktion. Wir gehen hier davon aus, dass der Datenbereich ab Zeile 3 und ab Spalte C beginnt.

Die Funktion sorgt dafür, dass nicht jede Zeile auf dem Blatt durchlaufen werden muss, sondern dass bereits eine Ergebnismenge vorhanden ist - es müssen also weniger Daten ausgewertet werden. Sie liefert einen Array, in dem die Zeilen enthalten sind, in denen sich die gefundenen Geburtstage befinden. Die einzelnen Daten sind Elemente jeder Zeile, der Geburtstag ist das vierte Element (ab Spalte C). Die Datumsangaben liegen in diesem Array als Long-Zahlen vor, deshalb sind sie hier noch formatiert.

Für den praktischen Einsatz kann es notwendig sein, die Blätter noch etwas einzugrenzen, weil sonst Fehler auftreten könnten. Hier wird mit IsArray() geprüft, ob ein Array vorliegt, fürs Grobe reicht das erst mal. Die Routine:

Sub Geburtstage1() Dim lngLZ As LongPtr Dim intN As Integer Dim strEintrag As String Dim wksBlatt As Worksheet Dim arrS(), lngArrS As LongPtr Dim varT lngArrS = -1 For Each wksBlatt In ActiveWorkbook.Sheets lngLZ = wksBlatt.Cells(wksBlatt.Rows.Count, 4).End(xlUp).Row varT = Application.Evaluate("=FILTER(" & wksBlatt.Name & "!C3:J" & lngLZ & ",(DAY(" & wksBlatt.Name & "!F3:F" & lngLZ & ")=DAY(TODAY()))*(MONTH(" & wksBlatt.Name & "!F3:F" & lngLZ & ")=MONTH(TODAY())),0)") If IsArray(varT) Then For intN = 1 To UBound(varT) lngArrS = lngArrS + 1 ReDim Preserve arrS(lngArrS) strEintrag = Format(varT(intN, 4), "DD.MM.YYYY") & " " strEintrag = strEintrag & Format(Year(Date) - Year(varT(intN, 4)), "00") & " " strEintrag = strEintrag & varT(intN, 3) & ", " & varT(intN, 2) strEintrag = strEintrag & ", Telefon: " & varT(intN, 8) strEintrag = strEintrag & " (Blatt: " & wksBlatt.Name & ")" arrS(lngArrS) = strEintrag Next End If Next UserForm1.ListBox1.List = arrS UserForm1.Show End Sub

Alte Variante, generell funktionshähig

Hier wird das Verwenden einer Schleife aufgezeigt.

Dazu wird natürlich eine Userform benötigt, hier ist es UserForm1. Auf ihr sind die ListBox1 und ein Commandbutton zum Schlie�en der Userform.

Die folgende Routine, die hier in einem Standardmodul sein muss, durchläuft alle Blätter und prüft in Spalte 6 (F) auf Datumsangaben. Wenn es sich um ein Datum handelt, wird auf �bereinstimmung mit dem heutigen Tag und dem heutigen Monat geprüft. Gibt es die, wird in diesem Beispiel einfach ein String aus den Angaben gebastelt und in einen Array aufgenommen.

Am Ende wird der Array mit UserForm1.ListBox1.List an die Listbox übergeben und die Userform aufgerufen.

Sub Geburtstage() Dim lngEZ As LongPtr, lngLZ As LongPtr, lngZ As LongPtr, lngS As LongPtr Dim strEintrag As String Dim wksBlatt As Worksheet Dim arrS(), lngArrS As LongPtr lngS = 6 lngArrS = -1 For Each wksBlatt In ActiveWorkbook.Sheets lngEZ = wksBlatt.UsedRange.Row lngLZ = lngEZ + wksBlatt.UsedRange.Rows.Count If lngLZ > lngEZ Then With wksBlatt For lngZ = lngEZ To lngLZ If IsDate(.Cells(lngZ, lngS)) Then If Day(.Cells(lngZ, lngS)) = Day(Date) And Month(.Cells(lngZ, lngS)) = Month(Date) Then lngArrS = lngArrS + 1 ReDim Preserve arrS(lngArrS) strEintrag = .Cells(lngZ, 6).Text & " " strEintrag = strEintrag & Format(Year(Date) - Year(.Cells(lngZ, 6)), "00") & " " strEintrag = strEintrag & .Cells(lngZ, 5) & ", " & .Cells(lngZ, 4) strEintrag = strEintrag & ", Telefon: " & .Cells(lngZ, 10) strEintrag = strEintrag & " (Blatt: " & .Name & ")" arrS(lngArrS) = strEintrag End If End If Next End With End If Next UserForm1.ListBox1.List = arrS UserForm1.Show End Sub

Es gibt natürlich auch Alternativen. So kann z. B. der Array mehrspaltig verwendet und das Ganze zu einer Funktion umgeschrieben werden, die den Array zurückgibt und beliebig eingesetzt werden kann. Oder die Listbox wird mit ColumnCount mehrspaltig erstellt und die einzelnen Daten werden auf mehrere Spalten verteilt. Oder die Daten werden sofort in die Listbox geschrieben. Oder, oder, oder �

Soll die Geburtstagsprüfung beim Dateiaufruf erfolgen, wird im Klassenmodul DieseArbeitsmappe (doppelt anklicken) dieser Code eingefügt:

Private Sub Workbook_Open() Geburtstage End Sub

Damit der Commandbutton wirkt: Doppelklick auf den Button und diesen Code eintragen:

Private Sub CommandButton1_Click() Unload Me End Sub

Das Add-In sammelt alle (nicht geschützten) Codeteile eines Projekts und schreibt sie übersichtlich in eine Tabelle. So können diese auch druckfertig aufbereitet werden.

Weiterhin besteht im Add-In die Möglichkeit, zu wählen, ob die aktive Tabelle oder die aktive Mappe gespeichert werden soll und ob dabei Makros aus der Kopie entfernt werden sollen.

Hinweis:

Damit Makros Zugriff auf den VBA-Code haben, muss in Excel folgende Einstellung vorgenommen werden:

• Datei > Optionen
• Trust Center (alt: Vertrauensstellungscenter)
• Einstellungen für das Trust Center
• Makroeinstellungen
• [X] Zugriff auf das VBA-Projektmodell vertrauen

Sonst erscheint eine Fehlermeldung.

Download: makros_auflisten.xlam

Sub MenuelementHinzu() MenuBars(xlWorksheet).Menus("Extras").MenuItems.Add Caption:="To&n", OnAction:="Ton" End Sub Sub Ton() Dim intI As Integer For intI = 1 To 10 Beep Next End Sub

Hinweis zu Excel 2007: Entfällt, da es das Menü nicht mehr gibt.

Sub MenueWiederherstellen() MenuBars(xlWorksheet).Menus.Add Caption:="Format", Before:=4, Restore:=True End Sub

Setzt man Enabled = True ist das Element wieder wählbar.

Sub MenuelementDeAktivieren() MenuBars(xlWorksheet).Menus("Extras").MenuItems("Ton").Enabled = False End Sub Sub MenuelementAktivieren() MenuBars(xlWorksheet).Menus("Extras").MenuItems("Ton").Enabled = True End Sub

Sub MenuelementLoeschen() MenuBars(xlWorksheet).Menus("Extras").MenuItems("Ton").Delete End Sub

Sub MenueLoeschen() MenuBars(xlWorksheet).Menus("MeinMenü").Delete End Sub

Wird Checked auf False gesetzt verschwindet das Häckchen.

Sub MenuelementHaekchen() MenuBars(xlWorksheet).Menus("Extras").MenuItems("Ton").Checked = True End Sub Sub MenuelementKeinHaekchen() MenuBars(xlWorksheet).Menus("Extras").MenuItems("Ton").Checked = False End Sub

Sub MenueHinzu() MenuBars(xlWorksheet).Menus.Add Caption:="Me&inMenü", Before:="?" End Sub

Hinweis zu Excel 2007: Entfällt, da es das Menü nicht mehr gibt.

Sub MenueelementWiederherstellen() MenuBars(xlWorksheet).Menus("Format"). MenuItems.Add Caption:="Zelle", Restore:=True End Sub

Die gesamte Tabelle nach ungeschützten Zellen durchsuchen zu lassen würde sicher zu lange dauern. Besser ist es, den Bereich, der durchsucht werden soll, einzugrenzen und dann in einer verschachtelten Schleife alle Inhalte ungeschützter Zellen zu löschen. Das Makro wäre dann:

Sub UngeschuetztLoeschen() Dim lngZ As Long, lngZ1 As Long, lngZ2 As Long, lngS As Long, lngS1 As Long, lngS2 As Long lngZ1 = 1 'Erste Zeile mit zu löschenden Inhalten lngZ2 = 100 'Letzte Zeile mit zu löschenden Inhalten lngS1 = 1 'Erste Spalte mit zu löschenden Inhalten lngS2 = 5 'Letzte Spalte mit zu löschenden Inhalten For lngZ = lngZ1 To lngZ2 For lngS = lngS1 To lngS2 Application.StatusBar = Cells(lngZ, lngS).Address If Cells(lngZ, lngS).Locked = False Then Cells(lngZ, lngS).ClearContents Next Next Application.StatusBar = False End Sub

Oder einfach per UsedRange:

Dim rngZelle As Range For Each rngZelle In ActiveSheet.UsedRange If rngZelle.Locked = False Then rngZelle.ClearContents Next

Immer wieder wird nach den Nachteilen von Select und Activate gefragt oder es wird darauf eingegangen. Leider wird es auch immer wieder genutzt - kein Wunder, denn selbst der Makro-Recorder zeichnet das ja so auf.

Fakt ist jedoch: Diese Anweisungen sollte man vermeiden, wo es immer geht.

Der Grund ist, dass man Blätter und Zellen immer erst aktivieren muss, wenn man mit ihnen arbeitet. Das ergibt nicht nur ein unschönes Bildschirmflackern (das man allerdings abstellen kann), sondern sorgt durch die Rechenbelastung auch dafür, dass die Routinen stark verlangsamt werden. Au�erdem spart man sich viel Code, wenn man Objekte direkt anspricht; die Programmierung wird also viel übersichtlicher.

Sollen alle Blätter der Mappe betroffen sein, ein Register mit rechts anklicken und Alle Blätter markieren wählen. Sonst die einzelnen Blattregister mit gedrückter Shift-Taste anklicken.

AnschlieÃ?end die Seiteneinstellungen vornehmen und ein beliebiges Register eines nicht aktiven Blattes anklicken.

Sub MenueleisteWiederherstellen() MenuBars(xlWorksheet).Reset End Sub

In Inputboxen werden zu suchender Text und neuer Text eingegeben. Anschlie�end wird auf jedem Tabellenblatt der Mappe die Ersetzung durchgeführt.

Sub suchersetz() Dim strSuchBegriff As String, strErsetzBegriff As String Dim wks As Worksheet strSuchBegriff = Application.InputBox("Bitte den zu suchenden Begriff eingeben") strErsetzBegriff = Application.InputBox("Bitte den Ersatzbegriff eingeben") For Each wks In ActiveWorkbook.Worksheets wks.UsedRange.Replace what:=strSuchBegriff, replacement:=strErsetzBegriff, lookat:=xlPart, searchOrder:=xlByColumns, MatchCase:=False Next End Sub

Ggf. kann hier noch eine Fehlerbehandlung eingebaut werden, wenn zum Beispiel eine InputBox abgebrochen wurde.

Beispielsweise durch eine Schleife über die Blätter der Mappe:

Sub Addieren() Dim dblSummen As Double, intI As Integer dblSummen = 0 For intI = 1 To Worksheets.Count dblSummen = dblSummen + Worksheets(intI).Range("A1") Next MsgBox dblSummen End Sub

Einsatz dynamischer Arrayfunktionen

Ein Lösungsansatz, der allerdings erst ab Excel 365 funktioniert, ist der Einsatz dynamischer Arrayfunktionen. Dadurch können die Daten vorgefiltert werden und per Schleife müssen nur noch die jeweiligen Ergebnismengen verarbeitet werden; eine Schleife über alle Zeilen ist nicht notwendig.

Gegeben ist die Tabelle mit den Namen in Spalte C ab Zeile 2 und Daten bis zur Spalte G. Dies müsste ggf. angepasst werden. Die letzte Zeile der Tabelle wird aufgrund der Daten in C automatisch erkannt.

Zuerst kommt die Tabellenblattfunktion EINDEUTIG() (UNIQUE()) zum Zug. Sie enthält jeden Namen aus Spalte C genau einmal. Dies ist wichtig, da für jeden Mitarbeiter ja nur ein Blatt erstellt werden soll. �ber das Ergebnis dieser Formel kann dann die Hauptschleife laufen: For Each varName In varNamen

In der Schleife wird dann für jeden Namen wieder eine Arrayfunktion verwendet: FILTER(). Diese liefert einen Array, der bei mehreren Zeilen zum Mitarbeiter aus diesen Zeilen mit den Zellen besteht oder bei nur einer Zeile aus den einzelnen Zellen. Damit hier kein Fehler auftritt, wird mit If UBound(varFilt) = Application.WorksheetFunction.CountA(varFilt) Then geprüft, wie viele Elemente der Array hat. Ist die Grö�e des Arrays gleich der Anzahl der einzelnen Elemente, handelt es sich um eine Zeile; die Elemente sind die Zellen. Ist die Grö�e des Arrays kleiner als die Anzahl der einzelnen Elemente, handelt es sich um mehrere Zeilen.

Beispiel: Bei zwei Zeilen ist der Ubound = 2. Jede Zeile hat vier Zellen, also sind das 2 Zeilen * 4 Zellen = 8 Elemente. Ubound ist kleiner als die Anzahl der Elemente. Bei nur einer Zeile hat der Array vier Elemente (die Zellen eben). Da der Array hier nicht nach Zeilen untergliedert ist, sondern die Zellen in der ersten Ebene liegen, ist hier Ubound auch = 4.

Diese Arrayelemente werden dann nur noch auf das hinzugefügte Blatt eingelesen.

Der Code:

Sub Aufteilen_Filter() Dim lngZ As LongPtr, lngLZ As LongPtr, intZ As Integer Dim strAktBlatt As String, strFormel As String Dim wksNeu As Worksheet Dim varFilt, varNamen, varName strAktBlatt = "Mitarbeiter" lngLZ = Cells(Rows.Count, 3).End(xlUp).Row varNamen = Application.WorksheetFunction.Unique(Range("C2:C" & lngLZ)) If IsArray(varNamen) Then For Each varName In varNamen strFormel = "=FILTER(" & strAktBlatt & "!C2:G" & lngLZ & "," & strAktBlatt & "!C2:C" & lngLZ & "=""" & varName & """)" varFilt = Application.Evaluate(strFormel) If IsArray(varFilt) Then Set wksNeu = Worksheets.Add(after:=Sheets(Sheets.Count)) wksNeu.Name = varName Sheets(strAktBlatt).Range("C1:G1").Copy wksNeu.Range("C1") lngZ = 1 If UBound(varFilt) = Application.WorksheetFunction.CountA(varFilt) Then lngZ = lngZ + 1 For intS = 1 To UBound(varFilt) wksNeu.Cells(lngZ, intS + 2) = varFilt(intS) '+2 weil Spalte C Next Else For intZ = 1 To UBound(varFilt) lngZ = lngZ + 1 For intS = 1 To 5 wksNeu.Cells(lngZ, intS + 2) = varFilt(intZ, intS) Next Next End If End If Next End If End Sub

Schleife

Vor Excel 365 funktioniert die Variante mit den dynamischen Arrayfunktionen noch nicht. Deshalb hier noch eine ältere Möglichkeit:

Die Routine duchläuft die Spalte der Mitarbeiternamen von oben nach unten. Mit Hilfe der Z�HLENWENN-Funktion wird geprüft, ob sich unterhalb der gerade durchlaufenen Zelle der Name des Mitarbeiters nochmals befindet. Wenn nicht, wird ein neues Blatt mit dem Namen des Mitarbeiters angelegt und es werden die Spaltenüberschriften eingefügt.

Zum Schluss werden die Daten zu den Mitarbeitern auf deren Blättern eingetragen.

Sub Aufteilen_Schleife() Dim lngZ As Long, lngLZ As Long, intAnzahl As Integer Dim lngAktZeile As Long Dim strAktBlatt As String, strName As String Dim ints, intAnzahlTB, intAnzahlSpalten As Integer Dim objNeuBlatt As Worksheet Dim lngErsteZeile As Long Dim strSpalte As String 'Hier anpassen: lngErsteZeile = 2 strSpalte = "C" strAktBlatt = ActiveSheet.Name lngLZ = Range(strSpalte & 65536).End(xlUp).Row 'Blätter mit den Spaltenüberschriften erstellen: For lngZ = lngErsteZeile To lngLZ If Sheets(strAktBlatt).Range(strSpalte & lngZ) <> "" Then intAnzahl = Application.WorksheetFunction.CountIf(Sheets(strAktBlatt).Range(strSpalte & lngZ + 1 & ":" & strSpalte & "65536"), Sheets(strAktBlatt).Range(strSpalte & lngZ)) If intAnzahl = 0 Then Set objNeuBlatt = Worksheets.Add(after:=Sheets(Sheets.Count)) objNeuBlatt.Name = Sheets(strAktBlatt).Range(strSpalte & lngZ) For ints = 1 To Sheets(strAktBlatt).Cells(1, Columns.Count).End(xlToLeft).Column objNeuBlatt.Cells(1, ints) = Sheets(strAktBlatt).Cells(1, ints) Next ints End If End If Next lngZ '�bernahme der Daten auf die einzelnen Blätter: intAnzahlSpalten = Sheets(strAktBlatt).Cells(1, Columns.Count).End(xlToLeft).Column For lngZ = lngErsteZeile To lngLZ strName = Sheets(strAktBlatt).Range(strSpalte & lngZ) If strName <> "" Then lngAktZeile = Sheets(strName).Range(strSpalte & 65536).End(xlUp).Row + 1 Sheets(strName).Range(Sheets(strName).Cells(lngAktZeile, 1), Sheets(strName).Cells(lngAktZeile, intAnzahlSpalten)).Value = _ Sheets(strAktBlatt).Range(Sheets(strAktBlatt).Cells(lngZ, 1), Sheets(strAktBlatt).Cells(lngZ, intAnzahlSpalten)).Value End If Next lngZ End Sub

Sub MenuelementUmbenennen() MenuBars(xlWorksheet).Menus("Extras").MenuItems("Ton").Caption = "Piep" End Sub Sub MenuelementUmbenennen1() MenuBars(xlWorksheet).Menus("Extras").MenuItems("Piep").Caption = "Ton" End Sub

Eine Möglichkeit ist, diese direkt in den Editor einzufügen - allerdings per Tastensimulation. Das geht sicher schnell, allerdings ist danach immer die Num-Taste ausgeschaltet:

Sub InTextExportieren() Dim intI As Integer Shell "Notepad.exe", 3 Application.SendKeys "Sicher ist die Num-Taste jetzt ausgeschaltet.~" For intI = 1 To 10 Application.SendKeys Sheets(intI).Range("A1").Value & "~" Next End Sub

Die bessere Alternative ist, die Werte in eine Textdatei zu speichern und anschlieÃ?end diese Textdatei mit Notepad aufzurufen:

Sub InTextExportieren1() Dim intI As Integer, strPfad As String, lngDNr As LongPtr strPfad = ThisWorkbook.Path & "\temp.txt" lngDNr = FreeFile Open strPfad For Output As #lngDNr For intI = 1 To 10 Print #lngDNr, Sheets(intI).Range("A1").Value Next Close #lngDNr Shell "Notepad.exe " & strPfad, 3 End Sub

Wie der Name schon sagt, geht es bei den Worksheet-Ereignissen um Aktivitäten in Bezug auf das einzelne Tabellenblatt.

Im Visual-Basic-Editor (Alt & F11) wird dazu im Projektfenster auf die jeweilige Tabelle doppelt geklickt und dann von "Allgemein auf "Worksheet gewechselt. Nun stehen im rechten Drop-Down-Feld die Ereignisse zur Verfügung.

Im Gegensatz zu den Workbook-Ereignissen, welche bei allen Tabellenblättern auftreten, sind die Worksheet-Ereignisse an das Tabellenblatt gebunden, indem sie stehen.

Parameterinfo

Bei verschiedenen Prozeduren werden auch Parameter übergeben. Diese verhalten sich wie folgt:

Ereignisse:

Worksheet_Activate

Tritt ein, wenn das Tabellenblatt aktiviert wird, also Blattwechsel zu diesem Blatt hin.

Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)

Tritt bei einem Doppelklick innerhalb der Tabelle ein.

Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)

Tritt bei einem Klick mit der rechten Maustaste innerhalb der Tabelle ein.

Worksheet_Calculate

Tritt ein, wenn Zellen dieses Blattes neu berechnet werden. Dieses Ereignis tritt auch dann ein, wenn sich ein Bezug verändert. Z. B. in B1 steht "= A1" und A1 wird verändert, so wird die Prozedur ausgeführt, da B1 neu berechnet wird.

Worksheet_Change (ByVal Target As Excel.Range)

Tritt ein, wenn mindestens eine Zelle im Tabellenblatt geändert wurde. Leider gibt es immer wieder Probleme bei externen Bezügen, wenn z. B. Daten per DDE geholt werden. Man sollte dann prüfen, ob man nicht mit dem Calculate zum Ergebnis kommt, indem man einen Bezug zur DDE-Zelle herstellt (=A1).

Worksheet_Deactivate

Tritt ein, wenn man von diesem Blatt aus zu einem anderem wechselt.

Worksheet_SelectionChange(ByVal Target As Excel.Range)

Tritt ein, wenn sich die Markierung im Tabellenblatt ändert.