Software für Sie.

Am einfachsten und sichersten ist es natürlich, im relevanten Code das enstprechende Blatt direkt anzusprechen:

Sheets("xxx").irgendwas

Soll geprüft werden, ob es sich beim aktiven Blatt um das Blatt XXX handelt, ist dies möglich:

If ActiveSheet.Name = "XXX" Then ...

Der Inhalt von A1 wird in die FuÃ?zeile eingetragen:

ActiveSheet.PageSetup.LeftFooter = Range("A1")

Pfad und Dateiname werden eingetragen:

ActiveSheet.PageSetup.LeftFooter = ActiveWorkbook.path & "\" & ActiveWorkbook.Name

Hier ist eine flexible Version, die es ermöglicht, beim Druck jede Seite einer Tabelle zu beeinflussen. Einzig und allein die Zelle mu� immer die gleiche sein, d. h. z. B., die achte von oben und siebte von links. Mit diesem Code lie�en sich dann auch die Fragen beantworten, wie man einen �bertrag auf die nächste Seite bringt.

Sub Druckseiteneinrichten() Dim intI As Integer, intJ As Integer, intK As Integer Dim intSeitenZaehler As Integer Dim intWievielteZeile As Integer, intWievielteSpalte As Integer ReDim arrSammler(1) 'Standardmä�ig wird bei jeder Seite der Inhalt der linken oberen Zelle 'zurückgegeben. Soll das eine andere sein, müssen die folgenden Werte 'geändert werden. 'Soll z. B. auf der ersten Seite der Inhalt von B4 zurückgegeben werden, 'mu� die erste Variable auf 3, die zweite auf 1 gesetzt werden '(vierte Zeile von oben, zweite Spalte von links). intWievielteZeile = 0 intWievielteSpalte = 0 ActiveWindow.View = xlPageBreakPreview ActiveSheet.ResetAllPageBreaks arrSammler(0) = 1 For intI = 1 To ActiveSheet.HPageBreaks.Count ReDim Preserve arrSammler(intI) arrSammler(intI) = ActiveSheet.HPageBreaks.Item(intI).Location.Row Next intSeitenZaehler = 0 For intJ = 0 To intI - 1 intSeitenZaehler = intSeitenZaehler + 1 Ausfuehren CInt(arrSammler(intJ)) + intWievielteZeile, _ 1 + intWievielteSpalte, _ intSeitenZaehler Next For intJ = 1 To ActiveSheet.VPageBreaks.Count intSeitenZaehler = intSeitenZaehler + 1 Ausfuehren CInt(arrSammler(0)) + intWievielteZeile, _ ActiveSheet.VPageBreaks.Item(intJ).Location.Column + intWievielteSpalte, _ intSeitenZaehler For intK = 1 To intI - 1 intSeitenZaehler = intSeitenZaehler + 1 Ausfuehren CInt(arrSammler(intK)) + intWievielteZeile, _ ActiveSheet.VPageBreaks.Item(intJ).Location.Column + intWievielteSpalte, _ intSeitenZaehler Next Next ActiveWindow.View = xlNormalView End Sub Sub Ausfuehren(Zeile As Integer, Spalte As Integer, SeitenZaehler As Integer) Dim strAnzeige$ strAnzeige = Cells(Zeile, Spalte) & " Seite: " & SeitenZaehler MsgBox strAnzeige ActiveSheet.PageSetup.LeftHeader = strAnzeige ActiveSheet.PrintOut from:=SeitenZaehler, To:=SeitenZaehler End Sub

Wie kann ich einen ausgewählten Bereich einer Exceltabelle als HTML-Mail via Outlook versenden?

Const strTempOrdner As String = "C:\Eigene Dateien\" Sub Aufruf() Mail_erstellen "info@example.org" End Sub Sub Mail_erstellen(strAdresse As String) Dim strQuelle As String Dim OutApp Dim OutMail Dim olMailItem Dim strSubject strQuelle = "$B$1:$R$58" strSubject = Range("B1") Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(olMailItem) With OutMail .To = strAdresse .CC = "" .BCC = "" .Subject = strSubject .HTMLBody = Uebersetzung(strQuelle) '.Send .Display End With Set OutMail = Nothing Set OutApp = Nothing End Sub Public Function Uebersetzung(strQuelle As String) Dim objFSO As Object Dim objInhalt As Object Dim strTempDatei As String strTempDatei = strTempOrdner & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" With ActiveWorkbook.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=strTempDatei, _ Sheet:=ActiveSheet.Name, _ Source:=strQuelle, _ HtmlType:=xlHtmlStatic) .Publish (True) End With Set objFSO = CreateObject("Scripting.FileSystemObject") Set objInhalt = objFSO.GetFile(strTempDatei).OpenAsTextStream(1, -2) Uebersetzung = objInhalt.ReadAll objInhalt.Close Set objInhalt = Nothing Set objFSO = Nothing Kill strTempDatei End Function

Bei neueren Outlookversionen kann es zu einer Fehlermeldung kommen:

Ein Programm versucht, Nachrichten mit Item.Send zu senden. Ein Programm versucht, mit dem Befehl Item.Send der Anwendung Microsoft Outlook Visual Basic automatisch E-Mail-Nachrichten zu senden. Wenn Sie möchten, dass das Programm diese E-Mail-Nachricht sendet, klicken Sie auf Ja. Klicken Sie auf Nein, um das Programm zu beenden. Wenn Sie sich nicht sicher sind, welches Programm die E-Mail-Nachricht sendet oder warum, sollten Sie auf Nein klicken, um ein mögliches Verbreiten von Viren zu vermeiden.

Bei Anzeige dieser Meldung steht die Schaltfläche Ja 5 Sekunden lang nicht zur Verfügung.

Vielleicht ist dieser Tipp besser geeignet: Mails mit VBA und PHP versenden (mehrere Empfänger, mehrere Anhänge).

In eine Inputbox kann der Name des zu erzeugenden Blattes eingetragen werden. Anschlie�end wird mit einer Schleife geprüft, ob der Name schon vergeben ist. Wenn nicht, wird das Blatt eingefügt und die Seitenränder werden festgelegt.

Sub Blatterstellen() Dim wksBlatt As Object Dim strNeu As String strNeu = InputBox("Bitte Namen des neuen Arbeitsblattes eingeben:") For Each wksBlatt In ActiveWorkbook.Sheets If wksBlatt.Name = strNeu Then MsgBox "Blattname existiert bereits!", vbOKOnly + vbExclamation, "Blatt hinzufügen" Exit Sub End If Next Sheets.Add ActiveSheet.Name = strNeu With Sheets(strNeu).PageSetup .LeftMargin = Application.CentimetersToPoints(1) .RightMargin = Application.CentimetersToPoints(1) End With End Sub

Eine andere Möglichkeit, bei der auch gleich festgelegt wird, wo das Blatt eingefügt werden soll:

Sub Blatterstellen1() Dim wksBlatt As Object Dim strNeu As String strNeu = InputBox("Bitte Namen des neuen Arbeitsblattes eingeben:") For Each wksBlatt In ActiveWorkbook.Sheets If wksBlatt.Name = strNeu Then MsgBox "Blattname existiert bereits!", vbOKOnly + vbExclamation, "Blatt hinzufügen" Exit Sub End If Next Set wksBlatt = Sheets.Add(before:=Sheets(1)) wksBlatt.Name = strNeu With wksBlatt.PageSetup .LeftMargin = Application.CentimetersToPoints(1) .RightMargin = Application.CentimetersToPoints(1) End With End Sub

Der Code leert zunächst die Listbox. Anschlie�end zeigt er den Dialog zur Dateiwahl, in dem die gewünschte Datei gewählt werden kann. Der Dialog wird so lange gezeigt, bis Abbrechen gewählt wird.

Bei der Listbox handelt es sich um ein ActiveX-Steuerelement

Sub DateienSammeln() Dim varPfad ActiveSheet.ListBox1.Clear varPfad = "" Do While varPfad <> False varPfad = Application.GetOpenFilename("Excel-Dateien (*.xl*), *.xl*") If varPfad <> False Then ActiveSheet.ListBox1.AddItem varPfad Loop 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

Wenn vorher bekannt ist, wie viele Unterstriche enthalten sein können, kann das verwendet werden:

Sub Unterstriche() Dim intI As Integer Application.ScreenUpdating = False '10 = maximale Zahl der Unterstriche For intI = 1 To 10 Range("A1:A65536").Replace What:="__", Replacement:="_", LookAt:=xlPart, SearchOrder:=xlByRows Next Range("A1").Select Application.ScreenUpdating = True End Sub

Ansonsten kann auch eine While-Schleife so lange laufen, wie noch doppelte Unterstriche gefunden werden:

Dim objGef As Object Set objGef = Cells.Find("__") Do While Not objGef Is Nothing Cells.Replace "__", "_" Set objGef = Cells.Find("__") Loop

Variante mit regulären Ausdrücken:

Sub Doppelte_Unterstriche() Dim strRepl As String, rngZelle As Range Dim Regex As Object, regMatches, regMatch If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") strRepl = "_" Regex.Global = True Regex.Pattern = "(__+)" For Each rngZelle In ActiveSheet.UsedRange Set regMatches = Regex.Execute(rngZelle) rngZelle = Regex.Replace(rngZelle, strRepl) Next Set Regex = Nothing End Sub

Der Druckbereich wird von der Zelle A10 bis zur Spalte E festgelegt. Die letzte Zeile des Druckbereichs ist hierbei die letzte Zeile, in der in Spalte A ein Eintrag vorhanden ist.

Sub druck() Dim intS As Integer, lngE As Long, lngZ As Long 'Spalte A: intS = 1 'Letzte Zeile mit Eintrag suchen: lngE = Cells(Rows.Count, intS).End(xlUp).Row 'Zeilen ausblenden: For lngZ = 10 To lngE If Cells(lngZ, 5) = "" Then Rows(lngZ).EntireRow.Hidden = True Next 'Druckbereich festlegen: ActiveSheet.PageSetup.PrintArea = "$A$10:$E$" & lngE 'Drucken: ActiveSheet.PrintOut 'Druckbereich aufheben: ActiveSheet.PageSetup.PrintArea = "" 'Zeilen einblenden: Rows.Hidden = False End Sub

Oder:

Sub ausblenden() Dim intI As Long, lngE As Long, lngL As Long, intS As Integer 'e = Erste Zeile mit Formel 'l = Zeile, in der Summe steht 's = Spalte, in der die Zellen auf "" überprüft werden sollen lngE = 1 lngL = 20 intS = 3 'Leere Zeilen ausblenden For intI = lngE To lngL If Cells(intI, intS).Text = "" Then Rows(intI).EntireRow.Hidden = True Next 'Drucken ActiveWindow.SelectedSheets.PrintOut Copies:=1 'Zeilen einblenden For intI = lngE To lngL Rows(intI).EntireRow.Hidden = False Next End Sub

Eine einfache Möglichkeit:

Sub BlattSpeichern() Dim strTBName As String, strWBName As String strTBName = InputBox("Blattname:") If strTBName = "" Then Exit Sub strWBName = InputBox("Dateiname:") If strWBName = "" Then Exit Sub Worksheets(strTBName).Copy ActiveWorkbook.SaveAs strWBName ActiveWorkbook.Close End Sub

Allerdings ist es natürlich einfacher, wenn man den Blattnamen nicht tippen muss. Die Namen der Tabellen können zur Auswahl auch in eine beliebige Liste eingetragen werden.

Eine andere Möglichkeit wäre, statt Worksheets(strTBName) das aktive Blatt zu verwenden, also ActiveSheet, wenn dies möglich ist.

Für alle Fälle sollte jedoch noch eine Fehlerbehandlung eingebaut werden, falls das Blatt mit dem eingegebenen Namen nicht existiert oder falls eine Datei mit dem eingegebenen Namen im aktiven Ordner (in den hier gespeichert wird) bereits vorhanden ist.

Damit das Speichern flexibler, komfortabler und vor allem sicherer wird, kann auch ein Dialog eingesetzt werden, zum Beispiel Application.GetSaveAsFilename. Hier wäre dann auch gleich der komplette Pfad enthalten.

Dieses Makro fügt die Nummern in Spalte E ein und "färbt" in der Spalte F.

Sub Farben() Dim intZ As Integer For intZ = 1 To 56 Cells(intZ, 5) = intZ Cells(intZ, 6).Interior.ColorIndex = intZ Next End Sub

Excel kann jedoch mit wesentlich mehr Farben umgehen, nämlich auch den RGB-Farben. Die kann man natürlich nicht alle auflisten, weil Excel in einer Mappe nur begrenzt Zellformate haben kann. Aber man kann Bereiche darstellen, zum Beispiel so:

Sub Farben1() Dim lngZ As LongPtr, intS As Integer, lngF As Long Dim lngStart As LongPtr Dim datBeg As Date Workbooks.Add ActiveSheet.Columns.ColumnWidth = 5 ActiveWindow.Zoom = 10 intS = 2 lngZ = 0 lngStart = 9895936 On Error GoTo FEHLER For lngF = lngStart To lngStart + 65279 lngZ = lngZ + 1 Cells(lngZ, intS) = lngF Cells(lngZ, intS).Interior.Color = lngF '65430 If lngZ Mod 256 = 0 Then intS = intS + 1 lngZ = 0 End If Next MsgBox Format(Now - datBeg, "mm:ss") Exit Sub FEHLER: MsgBox "Abbruch bei " & lngF & vbNewLine & "Fehler: " & Err.Number & vbNewLine & Err.Description End Sub

Mit der Zahl in lngStart kann einfach experimentiert werden.

Möglich ist auch, mit den RGB-Werten direkt zu arbeiten. Alle auf einmal verkraftet Exel nicht, also muss hier entweder mit Step oder durch kleinere Abbruchwerte reduziert werden:

Sub Farben2() Dim lngZ As LongPtr, intS As Integer, strRGB As String Dim datBeg As Date Dim r As Integer, g As Integer, b As Integer Workbooks.Add ActiveSheet.Columns.ColumnWidth = 5 ActiveWindow.Zoom = 10 intS = 2 lngZ = 0 On Error GoTo FEHLER For r = 0 To 255 Step 10 For g = 0 To 255 Step 7 For b = 0 To 255 Step 5 lngZ = lngZ + 1 strRGB = r & "|" & g & "|" & b 'Cells(lngZ, intS) = strRGB Cells(lngZ, intS).Interior.Color = RGB(r, g, b) If lngZ Mod 256 = 0 Then intS = intS + 1 lngZ = 0 End If Next Next Next MsgBox Format(Now - datBeg, "mm:ss") Exit Sub FEHLER: MsgBox "Abbruch bei " & strRGB & vbNewLine & "Fehler: " & Err.Number & vbNewLine & Err.Description End Sub

Die zweite Variante ist wahrscheinlich die optisch schönste, die ergibt solche Verläufe:

Angenommen in Spalte A und B stehen Zahlen, in Spalte C sollen jeweils die Summenformeln stehen. Die Zeilenanzahl wird durch die Spalte B bestimmt.

Variante mit englischer Syntax:

Sub Formeleinfuegen() Dim lngI As LongPtr For lngI = 1 To Cells(Rows.Count, 2).End(xlUp).Row ActiveSheet.Range("C" & lngI).Formula = "=SUM(A" & lngI & ",B" & lngI & ")" Next End Sub

Variante mit deutscher Syntax:

Sub Formeleinfuegen1() Dim lngI As LongPtr For lngI = 1 To Cells(Rows.Count, 2).End(xlUp).Row ActiveSheet.Range("C" & lngI).FormulaLocal = "=SUMME(A" & lngI & ";B" & lngI & ")" Next End Sub

Auf dem Tabellenblatt sind also mehrere Grafiken, deren Namen den Aufbau Bild x haben, wobei X für eine Zahl steht. In B2 soll diese Zahl eingetragen werden. Das entsprechende Bild soll dann auf C2 kopiert werden.

Der Code prüft zunächst, ob ein Bild mit dem Namen Symbol vorhanden ist. Wenn ja wird es gelöscht. Anschlie�end wird das Bild mit der jeweiligen Nummer kopiert, eingefügt, an C2 ausgerichtet und mit dem Namen Symbol versehen.

Sub Symbol_einfuegen() Dim strSymbol As String Dim shpSymb As Shape For Each shpSymb In ActiveSheet.Shapes If shpSymb.Name = "Symbol" Then shpSymb.Delete Next strSymbol = "Bild " & ActiveSheet.Range("B2").Value ActiveSheet.Shapes(strSymbol).CopyPicture xlScreen, xlBitmap With ActiveSheet.Pictures.Paste .Top = .Parent.Range("C2").Top .Left = .Parent.Range("C2").Left .Name = "Symbol" End With End Sub

Sub Range2CSV() Dim varPfad As Variant Dim strPfad As String, strText As String, strTemp As String Dim objZelle As Object Dim lngZeile As Long, lngI As Long, lngDnr As Long Dim intFrage As Integer If Workbooks.Count = 0 Then MsgBox "Keine Mappe offen.", vbOKOnly + vbInformation, "Keine Mappe" Exit Sub End If If ActiveSheet.Type <> -4167 Then MsgBox "Das aktive Blatt ist kein Tabellenblatt.", vbOKOnly + vbInformation, "Keine Tabelle" Exit Sub End If If Selection.Cells.Count = 1 Then MsgBox "Es ist kein Bereich markiert.", vbOKOnly + vbInformation, "Keine Markierung" Exit Sub End If varPfad = Application.GetSaveAsFilename("", "CSV-Dateien (*.csv), *.csv") If varPfad = False Then Exit Sub If Dir(varPfad) <> "" Then intFrage = MsgBox("Die Datei existiert bereits. Soll sie überschrieben werden?", vbYesNo + vbExclamation, "Datei existiert") If intFrage = vbNo Then MsgBox "Datei nicht erzeugt.", vbOKOnly + vbInformation, "Abbruch" Exit Sub End If End If strPfad = varPfad lngI = 0 strText = "" For Each objZelle In Selection lngI = lngI + 1 If lngI = 1 Then lngZeile = objZelle.Row If objZelle.Row = lngZeile Then strTemp = strTemp & objZelle.Text & ";" Else strTemp = Left(strTemp, Len(strTemp) - 1) strText = strText & strTemp & vbNewLine strTemp = objZelle.Text & ";" End If lngZeile = objZelle.Row Next strTemp = Left(strTemp, Len(strTemp) - 1) strText = strText & strTemp & vbNewLine lngDnr = FreeFile Open strPfad For Output As #lngDnr Print #lngDnr, strText Close #lngDnr MsgBox "Datei erzeugt.", vbOKOnly + vbInformation, "Fertig" End Sub

Download: range2csv.xlam

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

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 Auswahl() Dim rngZelle As Range, strBegriff As String strBegriff = InputBox("Bitte Suchbegriff eingeben:", Application.UserName) If strBegriff = "" Then Exit Sub Set rngZelle = ActiveSheet.Columns("A:F").Find(strBegriff) If rngZelle Is Nothing Then Beep MsgBox "Suchbegriff nicht gefunden!", , Application.UserName Exit Sub End If rngZelle.Select MsgBox rngZelle.Address(False, False) rngZelle.Offset(1).Select While ActiveCell.Address <> rngZelle.Address Cells.FindNext(After:=ActiveCell).Activate If ActiveCell.Address = rngZelle.Address Then Exit Sub MsgBox ActiveCell.Address(False, False) Wend End Sub

VBA

Sub TabellenblattName() MsgBox ActiveSheet.Name End Sub

Formel

Die Funktion =ZELLE("Dateiname";A1) gibt den Pfad der Mappe bis zur Tabelle zurück. Der Dateiname steht dabei in eckigen Klammern, danach kommt der Tabellenname. Also kann der Teil von der letzten eckigen Klammer bis zum Schluss extrahiert werden:

=RECHTS(ZELLE("Dateiname");LÃ?NGE(ZELLE("Dateiname"))-FINDEN("]";ZELLE("Dateiname")))

Hier gibt es viele Möglichkeiten.

Der folgende Code stellt die Zeile der letzten ausgefüllten Zelle in Spalte A (1) und die Spalte der letzten ausgefüllten Zelle in Zeile 1 fest. Anschlie�end wird genau eine Spalte in der Höhe dieser Daten markiert:

Dim lngZ As LongPtr, lngS As LongPtr lngZ = Cells(Rows.Count, 1).End(xlUp).Row lngS = Cells(1, Columns.Count).End(xlToLeft).Column Range(Cells(1, lngS + 1), Cells(lngZ, lngS + 1)).Select

Auch UsedRange kann ggf. gut eingesetzt werden. Hier wird neben dem UsedRange ein Bereich markiert, der genau so breit ist wie der UsedRange:

Dim lngS As LongPtr lngS = ActiveSheet.UsedRange.Columns.Count Range(ActiveSheet.UsedRange.Address).Offset(0, lngS).Select

Die Frage ist natürlich, warum markiert werden soll. Man kann die Elemente auch direkt ansprechen, dann zappelt auch der Bildschirm nicht so.

Indem man einfach die Schriftfarbe auf die Hintergrundfarbe setzt. Diese Routine setzt die Schriftfarbe der festgelegten Zellen auf die Hintergrundfarbe, druckt und setzt die Schriftfarbe wieder zurück:

Sub Drucken() Dim arrZellen(), arrSammler(), intI As Integer 'Hier die Zellen eintragen, deren Inhalte nicht gedruckt werden sollen: arrZellen = Array("B5", "C10", "C15", "D20", "E4", "E6", "E12") ReDim Preserve arrSammler(2, UBound(arrZellen)) For intI = 0 To UBound(arrZellen) arrSammler(0, intI) = arrZellen(intI) arrSammler(1, intI) = Range(arrZellen(intI)).Font.Color arrSammler(2, intI) = IIf(Range(arrZellen(intI)).Interior.ColorIndex = -4142, -4142, Range(arrZellen(intI)).Interior.Color) Range(arrZellen(intI)).Font.Color = Range(arrZellen(intI)).Interior.Color Next ActiveSheet.PrintOut For intI = 0 To UBound(arrZellen) Range(arrSammler(0, intI)).Font.Color = arrSammler(1, intI) If arrSammler(2, intI) = -4142 Then Range(arrSammler(0, intI)).Interior.ColorIndex = -4142 Else Range(arrSammler(0, intI)).Interior.Color = arrSammler(2, intI) End If Next End Sub

Hier werden zwei Varianten vorgestellt, bei denen Werte in mehrere Zellen in einer Zeile eingegeben werden können und diese als Filterkriterium dienen. Die Zellen, in die die Filterkriterien eingegeben werden können, sind hier A2:G2, also die ersten sieben Zellen in Zeile 2. Die Tabelle mit den zu filternden Werten ist darunter von A5:Gx.

In beiden Fällen im VBA-Editor auf die entsprechende Tabelle doppelklicken und den Code dort einfügen.

Ein Kriterium

Im ersten Beispiel richtet sich der Filter nach nur einem Kriterium, also einer Zelle in A2:G2. Wenn also z. B. in B2 etwas eingegeben wird, soll die Tabelle nach dem Eintrag in B2 gefiltert werden - etwaige Eintragungen in anderen Zellen in Zeile 2 werden ignoriert bzw. gelöscht:

Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim lngLZ As LongPtr, intS As Integer, intSAkt As Integer, bolEvent As Boolean If Target.Row <> 2 Or Target.Column > 7 Then Exit Sub lngLZ = Cells(Rows.Count, 1).End(xlUp).Row If ActiveSheet.AutoFilterMode = True Then If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData ActiveSheet.Range("A4:G" & lngLZ).AutoFilter End If bolEvent = Application.EnableEvents Application.EnableEvents = False For intS = 1 To 7 If intS <> Target.Column Then Cells(2, intS).ClearContents Next Application.EnableEvents = bolEvent If Target <> "" Then ActiveSheet.Range("A4:G" & lngLZ).AutoFilter Field:=Target.Column, Criteria1:=Range(Target.Address) End Sub

Nach der Eingabe werden zunächst alle Zeilen eingeblendet und der Autofilter ausgeschaltet, falls er gesetzt ist. Anschlie�end wird ausgeschaltet, dass die Tabelle auf Ereignisse reagiert (da es sonst zu Endlosschleifen kommen könnte) und die Inhalte der anderen Zellen in Zeile 2 werden gelöscht. Danach wird der Autofilter auf der Basis der aktuellen Eingabe gesetzt.

Mehrere Kriterien

In der zweiten Variante sind in Zeile 2 mehrere Einträge möglich und der Autofilter wird auf der Basis dieser Einträge gesetzt. Das Vorgehen entspricht ansonsten der ersten Variante.

Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim lngLZ As LongPtr, intS As Integer If Target.Row <> 2 Or Target.Column > 7 Then Exit Sub lngLZ = Cells(Rows.Count, 1).End(xlUp).Row With ActiveSheet If .AutoFilterMode = True Then If .FilterMode = True Then .ShowAllData .Range("A4:G" & lngLZ).AutoFilter End If For intS = 1 To 7 If .Cells(2, intS) <> "" Then .Range("A4:G" & lngLZ).AutoFilter Field:=intS, Criteria1:=.Cells(2, intS).Value End If Next End With End Sub

Eingabe nur in A2 - ältere Variante mit weniger Funktionalität

Im VBA-Editor auf die Tabelle doppelt klicken, in der es funktionieren soll. Anschlie�end in das Modul einfügen:

Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address <> "$A$2" Then Exit Sub ActiveSheet.Range("A4:B" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter If Range("A2") <> "" Then ActiveSheet.Range("A4:B" & Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=1, Criteria1:=Range("a2") End If End Sub

Dieser Code ersetzt das unsichtbare Zeichen mit einem Mal in allen Zellen der aktiven Tabelle:

Sub ZeilenumbruecheErsetzen() ActiveSheet.Cells.Replace Chr(10), " " End Sub

Ggf. sollte noch geprüft werden, ob der Blattname schon vergeben ist. Das �bernehmen geht einfach:

Sub Name_anpassen() ActiveSheet.Name = Range("a5").Value End Sub