Jörg Lorenz: Excel, VBA-Beispiele

Excel-Beispiele: Erklärungen, Formeln, VBA-Code und mehr

Hinweise zu den Beispielen finden Sie hier: Beispiele

Kategorie: Beispiel > Excel > VBA > Mappe

Aktives Blatt: Name

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 107)

Ich möchte, daß sich bestimmte Makros nur auf Worksheet xxx eines Workbooks auswirken. Wie lautet die Syntax?

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

Blätter sortieren

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 108)

Die Tabellenblätter einer Mappe sind mit Tab1, Tab2, ..., Tab50, Tab51, usw. durchnummeriert. Wie kann ich sie sortieren?

1. Möglichkeit: (Reihenfolge Tab1, Tab2, Tab11; Blätter werden zum Schluss gezählt)

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

2. Möglichkeit: (Reihenfolge Tab1, Tab11, Tab2; Blätter werden nicht gezählt)

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

Bildschirmaktualisierung aus- und einschalten

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 109)

Wie kann ich erreichen, daß ein Makro nicht alle einzelnen Schritte anzeigt?

Bildschirmaktualisierung ausschalten:

Application.ScreenUpdating = False

Bildschirmaktualisierung einschalten:

Application.ScreenUpdating = True

Hinweis:
Man sollte weitestgehend darauf verzichten, die Bildschirmaktualisierung auszuschalten, indem man man die Programme streng objektorientiert entwickelt.

Blatt einfügen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 110)

Wie kann ich ein neues Blatt einfügen? Dabei soll überprüft werden, ob ein Blatt mit dem Namen schon existiert und der linke und rechte Seitenrand auf einen Zentimeter festgelegt werden.

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

Datei schließen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 111)

Wie kann ich per Makro eine Datei schließen?.

Datei schließen ohne zu speichen: ACHTUNG: Änderungen werden nicht berücksichtigt!

Sub DateiSchliessen()
Workbooks("MeineDatei.xls").Close SaveChanges:=False
End Sub

Datei schließen mit speichern:

Sub DateiSchliessen()
Workbooks("MeineDatei.xls").Close SaveChanges:=True
End Sub

In diesem Beispiel werden alle geöffneten Arbeitsmappen geschlossen. Bei Änderungen öffnet Excel den Dialog zum Speichern der Änderungen.

Sub DateiSchliessen()
Workbooks.Close
End Sub

Blatt in eine andere Mappe kopieren

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 112)

Auf dem Blatt "Huber" steht in A10 der Pfad und der Name der Datei "Ablage.xls". In diese Datei möchte ich das Blatt "Huber" kopieren. Das Blatt soll in der Datei als letztes erscheinen; diese soll anschließend geschlossen werden.

Sub Blatt_kopieren()
Dim strName As String
strName = ActiveWorkbook.Name
Workbooks.Open Filename:=Sheets("Huber").Range("A10")
Workbooks(strName).Activate
Sheets("Huber").Copy after:=Workbooks("Ablage.xls").Sheets(Sheets.Count)
Workbooks("Ablage.xls").Close savechanges:=True
End Sub

Summe aus A1 von allen Blättern

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 114)

Wie kann ich die Summe von A1 aus jedem Blatt bilden?

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

Daten von mehreren Blättern zusammenfassen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 115)

Ich habe mehrere Blätter mit Daten. Alle Blätter haben unterschiedlich viele Datensätze (Datenzeilen). Alle Daten sollen nacheinander auf einem Blatt zusammengefaßt werden.

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

Dialogfeld Speichern unter aufrufen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 116)

Wie kann ich das Dialogfeld Speichern unter aufrufen?

1. Möglichkeit:

Sub SPU()
Dim varPfad
varPfad = Application.Dialogs(xlDialogSaveAs).Show("test.xls")
Select Case varPfad
    Case -1     'Gesichert
    Case 0      'Abgebrochen
End Select
End Sub

2. Möglichkeit (In A1 steht der Dateiname.):

Sub SPU1()
Dim varPfad
varPfad = Application.GetSaveAsFilename(Range("A1"))
If varPfad = False Then Exit Sub
ActiveWorkbook.SaveAs varPfad
End Sub

Eine Datei zur Arbeit mit integrierten Dialogfeldern finden Sie in der Beispieldatei:

Dialogfeld Datei öffnen aufrufen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 117)

Wie kann ich das Dialogfeld Datei öffnen aufrufen?

Sub Oeffnen()
Dim varPfad
varPfad = Application.GetOpenFilename("Microsoft Excel-Dateien (*.xls), *.xls")
If varPfad = False Then Exit Sub
Workbooks.Open Filename:=varPfad
End Sub

Eine Datei zur Arbeit mit integrierten Dialogfeldern finden Sie in der Beispieldatei:

Titelleiste von Excel ändern

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 118)

Wie kann ich die Titelleiste von Excel ändern?

Die Titelleiste der Anwendung kann man ändern mit:

Application.Caption = "So wie Du willst"

Zurücksetzen:

Application.Caption = Empty

Die Titelleiste der Mappe kann man einrichten mit:

ActiveWindow.Caption = "Ich bin ein Fenster."

Anwendung Excel beenden

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 119)

Wie kann ich per Makro Excel beenden, ohne daß gefragt wird, ob die Änderungen gespeichert werden?

Suggeriert, daß die Datei gespeichert ist (wenn nicht gespeichert werden soll) und beendet Excel ohne nachzufragen:

ThisWorkbook.Saved = True
Application.Quit

Speichert erst und beendet Excel:

ThisWorkbook.Save
Application.Quit

Speichern ohne Meldung

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 120)

Wie kann ich beim Vorhandensein einer Mappe eine neue ohne Fehlermeldung unter dem Namen der alten speichern?

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="g:\Test\Test.xls"
Application.DisplayAlerts = True

Suche über mehrere Blätter

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 121)

Wie kann ich auf allen zur Mappe gehörenden Blättern suchen und ersetzen?

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

Integrierte Dialogfelder aufrufen:

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 437)

Tabellenblatt auf mehrere Tabellenblätter aufteilen

Nach oben Adresse des Beitrags Nachricht zum Beitrag an Autor (Tipp 551)

Auf einem Tabellenblatt befinden sich in Spalte C die Namen der Mitarbeiter, daneben ihre Daten. Wie kann ich für jeden Mitarbeiter ein neues Blatt per VBA erstellen, auf dem seine Daten untereinander aufgelistet sind?

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()
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

Excel, Scripte, Alltagslösungen

Jörg Lorenz

Datenschutzerklärung