auxmoney - Geld leihen für das Studiumauxmoney - Geld leihen für das Studium

auxmoney - Geld leihen für den Umzugauxmoney - Geld leihen für den Umzug

VBA-Makros für Excel (Teil I)

VBA-Makros für Excel (Teil I) - Sammlung diverser Makros
Kleine Übersetzung Application = Anwendung
Workbook = Arbeitsmappe
Worksheets = Arbeitsblätter
Range = Zelle
Beispiele zum Befehl "Range" Sub Text1()
Range("B3:F5").Value = "Test" Zellen wird der Wert "TEST"zugewiesen
End Sub
Sub Text3()
Dim a As String A und B wurden als Zeichenkette deklariert.
Dim B As String
a = 5
B = 4
Range("b6") = a + B Zelle B6 wird die Zeichenkette (54)
End Sub zugewiesen.
Sub Text2()
Range("b2:f15").Activate Activate markiert den Zellbereich.
End Sub
Sub Text4()
Dim Lolo As Integer Lolo und t wurden als Zahlen deklariert.
Dim t As Integer
Lolo = 17
t = 8
Range("c12") = Lolo * t Es wird das Produkt aus 17 mal 8
  End Sub zugewiesen.
Arbeitsblatt schreibschützen Sub Protect()
Dim a$
ActiveSheet.Protect
a = "winner"
B = InputBox("Bitte geben Sie das Passwort ein")
If B = a Then
ActiveSheet.Unprotect
Range("b7").Select
Else
MsgBox "Access denied"
ActiveWorkbook.Close
End If
  End Sub  
Excel Modul verstecken / wieder- Sub ModulVerstecken() Sub ModulWiederEinblenden()
herstellen Modules(1).Visible = xlVeryHidden Modules(1).Visible = True
  End Sub End Sub
Arbeitsblätter sortieren Sub ABlattSortieren() Durch Änderung des < - Zeichens in ein > -
Dim i%, j% Zeichen kann eine absteigende
For i = 1 To Sheets.Count Sortierung erreicht werden.
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  
Datei unter Tagesdatum speichern Sub DateiUnterTagesdatumAbspeichern()
Dim Tagesdatum As String, Sicherung As String
Tagesdatum = Application.Text(Now(), "mm-dd-yy hh-mm")
Sicherung = "Backup" & Tagesdatum & ".XLS"
ActiveWorkbook.SaveCopyAs Sicherung
  End Sub  
Datei unter Tagesdatum speichern Sub DateiUnterTagesdatumAbspeichern()
(Ordner vorgeben) Dim Dateiname As String, Ppfad As String
Dateiname = Format(Now(), "ddmmyyyy")
Ppfad = "D:\MyFiles\"
ActiveWorkbook.SaveAs (Ppfad & Dateiname) ActiveWorkbook.SaveAs filename:= _
  End Sub "C:\myfile.xls", FileFormat:=xlNormal
Datei unter Tagesdatum speichern Sub DateiUnterTagesdatumAbspeichern()
(mit Dialogfeld) Dim Dateiname As String
Dateiname = Format(Now(), "yyyy-mm-dd")
Application.Dialogs(xlDialogSaveAs).Show (Dateiname)
  End Sub  
Prüfung, ob Zelle numerischen Sub NumerischerWertInZelle()
Inhalt hat If Not Application.IsNumber(ActiveCell) Then
MsgBox "Zelle enthält kein numerisches Zeichen"
End If
  End Sub  
Alle Excel-Dateien eines Sub DateinamenAuflisten()
bestimmten Verzeichnis Dim Dateiname$, i%
anzeigen Dateiname = Dir$("c:\temp\*.xls")
Do While Dateiname <> ""
ActiveCell.Offset(i, 0) = Dateiname
i = i + 1
Dateiname = Dir$()
Loop
  End Sub  
Berechnungsfunktion in Arbeits- In einer umfangreichen Arbeitsmappe soll die Berechnungsfunktion ausgeschaltet werden und nur
mappe ausschalten Berechnungen auf der jeweils aktuellen Seite zulassen. Immer wenn auf einem Blatt eine Eingabe
gemacht wird und zum Abschluß die Enter-Taste gedrückt wird, soll das Makro aktiv werden und nur
das jeweils aktive Blatt aktualisieren
Sub Auto_Open()
Application.Calculation = xlManual
Application.MaxChange = 0.001
ActiveWorkbook.PrecisionAsDisplayed = False
Application.OnKey "{ENTER}", "JeweilsNurDasAktiveTabellenblattBerechen"
  End Sub  
Prüfung, ob Excel-Datei geöffnet Function ArbeitsmappeOffen(AMappe As String) As Boolean
ist On Error Resume Next
MappeText = Workbooks(AMappe).Name
On Error GoTo Fehler
Workbooks.Open AMappe
OpenBook = True
Exit Function
Fehler: ArbeitsmappeOffen = False
  End Function  
Namen und Position einer Schalt- Sub NameUndPosEinerSchaltfläche()
fläche wiedergeben Dim x
Set x = ActiveSheet.Shapes(Application.Caller)
MsgBox x.Name
MsgBox x.TopLeftCell.Address
Range(x.TopLeftCell.Address).Select
Range(ActiveCell, ActiveCell.Offset(1, 1)).Select
  End Sub  
Schaltfläche deaktivieren Sub SchaltflächeDeaktivieren()
Sheets("Tabelle1").Buttons(1).Enabled = False Auf dem Arbeitsblatt Tabelle1 wird die erste
  End Sub Schaltfläche deaktiviert.
Löschen der Zwischenablage Sub ZwischenablageLöschen()
Application.CutCopyMode = False
  End Sub  
Menüleiste ausblenden Sub MenüleisteAusblenden()
Application.CommandBars("Worksheet Menu Bar").Enabled = False
End Sub
Menüleiste einblenden Sub MenüleisteEinblenden()
Application.CommandBars("Worksheet Menu Bar").Enabled = True
  End Sub  
SchaltflächenNamen in Sub SchaltflächenNamenInMsgBoxAusgeben()
MsgBox ausgeben MsgBox (ActiveSheet.Buttons(Application.Caller).Text)
  End Sub  
Anzahl der verwendeten Zeilen Sub AnzahlVerwendeteZeilen()
eines Blatts ausgeben i = ActiveSheet.UsedRange.Rows.Count
MsgBox i
  End Sub  
Mehrere Zeilen markieren Sub MehrereZeilenMarkieren()
Range("1:1,3:3,5:5,9:9,11:11").Select
  End Sub  
Excel beenden Sub ExcelBeenden()
Application.Quit
  End Sub  
Vor dem Speichern einer Datei Sub Auto_Open()
ein Makro aufrufen ActiveWorkbook.OnSave = "MacroX"
End Sub
Sub MacroX()
ActiveSheet.PageSetup.LeftFooter = "&8" + ActiveWorkbook.Path
End Sub
Vor Speichern wird MakroX aufgerufen, welches aktuellen Pfad einer Datei in Fußzeile überträgt.
Weisen Sie im Modul Auto_Open der Aktion OnSave zuvor noch das Modul MacroX zu.
Excel merkt sich, daß die Aktion mit einem Makro verknüpft ist.
Sobald man nun die Datei speichert, läuft vor dem Speichern das Makro MacroX.
Auto_Open klappt nicht immer, also probieren wir es so:
Sub ActiveWorkbook_BeforeSave()
ActiveSheet.PageSetup.LeftFooter = "&8" + ActiveWorkbook.Path
  End Sub  
Text aus Textbox auf Sub cmdButton1_Click() Bedingung: Der Text in der Textbox muss mit
verschiedene Zellen Dim i%, Zeile$ Umschalt und Enter umgebrochen werden.
aufteilen Zeile = TextBox1.Text Außerdem:
While InStr(Zeile, Chr(10)) > 0 MultiLine = True und WordWrap = True
i = i + 1 zuweisen.
Tabelle1.Cells(i, 1) = Left(Zeile, InStr(Zeile, Chr(10)) - 2)
Zeile = Right(Zeile, Len(Zeile) - InStr(Zeile, Chr(10)))
Wend
Tabelle1.Cells(i, 1) = Zeile
  End Sub  
Text aus Textbox auf Sub cmdButton1_Click() Hier muss der Text in der Textbox nicht umge-
verschiedene Zellen Dim i%, e%, h$, var$ brochen werden; das Makro liest die Zeilen
aufteilen var = Me.TextBox1 einzeln heraus und überträgt sie zeilenweise
Me.TextBox1.SetFocus auf ein Worksheet.
SendKeys "^{HOME}" Kompletten Text in Variable sichern.
Do
i = i + 1
SendKeys "^{HOME}" Cursor an den Anfang des Textes.
SendKeys "+{END}" Bis zum Ende der Zeile markieren.
e = DoEvents() Übergeben der Ablaufsteuerung ans System.
h = Me.ActiveControl.SelText Hier steckt der auszulesende Text.
Cells(i + 3, 3) = h Überträgt Text zeilenweise vertikal in Spalte 3.
SendKeys "{DEL}" Markierten Text löschen.
Loop Until h = ""
MsgBox "Anzahl der Zeilen war: " & i
Me.TextBox1 = var Kompletten Text aus Variable in TextBox
  End Sub zurückschreiben.
Alle ausgeblendeten Zellen Sub AlleAusgeblendetenZeilenAnzeigen()
eines Arbeitsblattes anzeigen Dim r
For Each r In ActiveSheet.UsedRange.Rows
If r.Hidden = True Then r.Hidden = False
Next r
  End Sub  
HTML-Datei mit fester Fenster- Sub InternetExplorer_Oeffnen()
größe öffnen Dim objExplorer As Object, varFile As Variant
varFile = Application.GetOpenFilename("HTML-Dateien (*.ht*), *.ht*")
Set objExplorer = CreateObject("InternetExplorer.Application")
With objExplorer
.Navigate varFile
.StatusBar = False
.MenuBar = False
.Toolbar = False
.Visible = True
.Resizable = False
.Offline = True
.Width = 650
.Height = 550
End With
  End Sub  
Werte aus einer Textfeld-Serie Sub cmdUebertragen_Click()
in Arbeitsblatt übertragen Dim objCtr As Control, intRow%
intRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
For Each objCtr In Controls
If TypeName(objCtr) = "TextBox" Then
Cells(intRow, 1) = objCtr.Text
intRow = intRow + 1
End If
Next objCtr
Unload Me
  End Sub  
Zeigt Workbook Blatt für Blatt Sub Intervall()
in zeitlichen Intervallen an Dim Anzahl%, i%, Button%
Anzahl = ActiveWorkbook.Worksheets.Count
For i = 1 To Anzahl
Worksheets(i).Activate
Application.Wait Now + TimeValue("00:00:03")
Worksheets(i).Select
Next
Button = MsgBox(Prompt:="Die Slide-Show ist nun beendet. Sollen die _
Arbeitsblätter nun nach Namen sortiert werden?", Buttons:=vbOKCancel _
+ vbQuestion)
If Button = vbOK Then ArbBlattSortieren
  End Sub  
WochenEnden kenntlich machen Sub WochenendenFärben()
For Each oCell In Range(Cells(1, 4), Cells(1, 34))
If WeekDay(oCell.Value) = 7 Or WeekDay(oCell.Value) = 1 Then
With oCell.Interior
.Pattern = xlGray16
.PatternColorIndex = 42
End With
End If
Next oCell
  End Sub  
Fußzeile erzeugen Sub FussZeileErzeugen()
With ActiveSheet.PageSetup
.LeftFooter = "&""Arial,Fett""&12&A" Linksbündig Dateiname
.RightFooter = "Seite &P von &N" Rechtsbündig Seitenzahlen
.CenterFooter = ActiveSheet.Parent.FullName Dateinamen inklusive Pfadangabe
End With
Worksheets("Sheet1").PageSetup.CenterFooter _ Name der Arbeitsmappe und Seitenzahl
= "&F Seite &P"
  End Sub  
Aufruf eines externen Sub ProgrammAusExcelAufrufen()
Programms aus Excel Status = Shell("notepad.exe"; 1) Weitere Beispiele: Calc.exe = Taschenrechner.
  End Sub MsPaint.exe = Zeichenprogramm.
Sol.exe = Solitär.
Anzahl der Excel-Dateien eines Sub ExcelDateienZaehlen()
Verzeichnisses ausgeben With Application.FileSearch
.NewSearch
.LookIn = "C:\Eigene Dateien"
.FileName = "*.xls"
.Execute
MsgBox .FoundFiles.Count
End With
  End Sub  
Nur aktives Tabellenblatt Sub JeweilsNurDasAktiveTabellenblattBerechen()
berechnen Application.MaxChange = 0.001
ActiveWorkbook.PrecisionAsDisplayed = False
ActiveSheet.Calculate
  End Sub  
Sekunden in dreistelligem Function milHours(dteTime As Date) Bruchteile von Sekunden werden bei einer
Dezimalwert anzeigen Dim i% Zeitformatierung dezimal dargestellt:
i = Second(dteTime) also hh:mm:000, z.B. 12:05:456
i = i / 60 * 1000 Dieses Modul mit folgendem Syntax auf
milHours = Format(Hour(dteTime), "00") & ":" & _ dem Worksheet aktivieren:
Format(Minute(dteTime), "00") & ":" & i =Projektname.xls!milHours(A1)
  End Function  
Töne am PC erzeugen Sub PcPiep()
AnzBeeps = InputBox("Wie oft soll gepiepst werden ?")
For Count = 1 To AnzBeeps
Beep
Application.Wait Now() + TimeValue("00:00:01") Zwischen jedem Pieps liegt eine Pause von
Next Count einer Sekunde.
  End Sub  
Öffnen-Dialogfeld beim Laden Sub Auto_Open()
der Anwendung zeigen On Error Resume Next
Application.Dialogs(xlDialogOpen).Show
Application.Dialogs(xlDialogOpen).Show "Muster.xls" Bei Angabe des Dateinamens springt der
  End Sub Dialog gleich ins richtige Verzeichnis.
Bildschirm auf Ganzansicht Sub AnsichtGanzerBildschirm()
umstellen Application.DisplayFullScreen = True
  End Sub  
Benutzerdefinierte Namen Sub AlleNamenInMappeLöschen()
löschen Dim definedName As Object
For Each definedName In ActiveWorkbook.Names Löscht Namen in allen Worksheets
definedName.Delete
Next
  End Sub  
Namen der aktiven Datei in Function DateiName()
eine Zelle schreiben DateiName = ActiveWorkbook.Name In Zelle A1 z.B. den Befehl: =DateiName()
  End Function eingeben.
Aktives Tabellenblatt Sub ArbeitsblattUmbenennen()
umbenennen ActiveSheet.Name="Neuer Name"
  End Sub  
Tastatureingabe (KeyAscii) Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
abfragen MsgBox Prompt:="Der KeyAscii lautet " & KeyAscii
  End Sub  
Tabelle automatisch sortieren Sub Worksheet_Activate()
(zwei Möglichkeiten) UsedRange.Select Markiert benutzten Bereich.
Selection.Sort Key1:=Range(.......... ) Bereich vorher über Makro ermitteln.
Range("A1").Select: Range("A2").Select Setzt Markierung zurück.
End Sub
Sub Worksheet_Change(ByVal Target As Excel.Range)
UsedRange.Select Markiert benutzten Bereich.
Selection.Sort Key1:=Range(..........) Bereich vorher über Makro ermitteln.
Target.Select Setzt Markierung zurück.
  End Sub  
Inhalt + Länge eines Textfeldes Sub TextAusTextfeld()
ausgeben Dim t%, z%
With ActiveSheet.TextBoxes(1)
For z = 1 To .Characters.Count Step 255
t = t & .Characters(z, 255).Text Das erste Textfeld des aktiven Tabellen-
Next z blattes wird ausgelesen.
End With
MsgBox Len(t) & " " & t Der Operator & verkettet die Anzahl der
  End Sub Zeichen und den Inhalt des Textfeldes.
Mit Doppelklick auf eine Zelle, Sub Worksheet_BeforeDoubleClick(ByVal Target As _
die einen Blattnamen beinhaltet, Excel.Range, Cancel As Boolean)
zum jeweiligen Arbeitsblatt Dim i%
springen Cancel = True
On Error GoTo ErrorHandler
Worksheets(Target.Value).Select
i = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveSheet.Cells(i, 1).Select
Exit Sub
ErrorHandler:
MsgBox "Tabellenblatt nicht gefunden!"
  End Sub  
Hyperlink mit E-Mailadresse Sub HyperlinkMitEmailEinfügen()
einfügen und aktivieren Range("A1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, _
Address:= "mail:me@a.com"
End Sub
Sub HyperlinkAktivieren()
Range("A1").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
  End Sub  
Werte per Tastenkombination Sub Auto_Open()
einfügen (STRG + W) Application.OnKey "^w", "WerteEinfügen"
End Sub
Sub WerteEinfügen()
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:= False, Transpose:=False
  End Sub  
Über InputBox einen Eintrag Sub EingabeÜberInputbox()
vornehmen und in Zelle Dim wert01$
zurückschreiben wert01 = InputBox("Wert eingeben", "Bitte geben Sie einen Wert ein")
Range("a1").Value = wert01
  End Sub  
Immer das erste Worksheet im Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Workbook ansprechen Cancel As Boolean)
Sheets(1).Activate
  End Sub  
Web-Symbolleiste nicht Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, _
anzeigen ByVal Target As Hyperlink)
Application.CommandBars("Web").Visible = False
  End Sub  
Bei Klick auf das Schließkreuz Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
einer UserForm soll das If CloseMode = vbFormControlMenu Then _ Auch möglich:
Schließen verhindert werden Cancel = True If CloseMode <> 1 Then Cancel = 1
  End Sub  
Grafiken und Zeichnungen aus Sub Grafiken_Entfernen()
Worksheet entfernen Dim xShape As Shape
On Error GoTo ende
Application.ScreenUpdating = False
For Each xShape In ActiveSheet.Shapes
xShape.Delete
Next xShape
Exit Sub
ende:
Exit Sub
  End Sub  
Hyperlinks aus Worksheet Sub Hyperlinks_Entfernen()
entfernen Dim xLink As Hyperlink
On Error GoTo ende
Application.ScreenUpdating = False
For Each xLink In ActiveSheet.Hyperlinks
xLink.Delete
Next xLink
Cells.Select
Selection.Font.Name = "Arial" Setzt den Schrifttyp zurück.
Selection.Font.Size = 8
Range("a1").Select
Exit Sub
ende:
Exit Sub
  End Sub  
Hyperlinks im Worksheet Sub Hyperlinks_Markieren()
markieren On Error GoTo end1
FirstCell = 1
For Each xLink In ActiveSheet.Hyperlinks
If FirstCell = 1 Then
Set xRange = xLink.Range
FirstCell = 0
Else
Set xRange = Application.Union(xRange, xLink.Range)
End If
Next xLink
xRange.Select
end1: Exit Sub
  End Sub  
Error-Object abfragen Sub ProgrammXYZ()
If Err > 0 Then Error-Objekt.
Err.Clear
irgendwelche Befehle
End If
On Error Goto 0
  End Sub  
Zeiteingaben vereinfachen: Sub TimeXYZ() Makro mit Schaltfläche auf dem Worksheet:
Keine Eingabe des Dim c As Range Spalte des Worksheets als Text formatieren.
Doppelpunktes notwendig For Each c In Selection Zeiten per Tastatur eingeben: z.B. 1215.
c = TimeSerial(Left(c, 2), Right(c, 2), 0) Eintragungen anschließend selektieren.
c = Format(c, "hh:mm") Programm mit CommandButton starten.
Next c Ergebnis: 12:15
  End Sub  
Sanduhr aktivieren / deaktivieren Sub ProgramXYZ() Screen.MousePointer = vbHourglass
Application.Cursor = xlWait schaltet die Sanduhr ein.
irgendwelche Befehle Screen.MousePointer = vbDefault
Application.Cursor = xlNorthwestArrow 'oder: xlDefault schaltet den Zeiger wieder ein.
  End Sub  
Spaltenbreite automatisch Sub Worksheet_Calculate() Dieses Makro in die Tabelle einbinden!
anpassen Columns("A:G").AutoFit Die Spaltenbreite wird immer nach Zell-
  End Sub Eingabe automatisch angepasst.
Spaltenbreite automatisch Sub Workbook_SheetCalculate(ByVal Sh As Object) Dieses Makro in das Workbook einbinden.
anpassen Columns("B:E").AutoFit Die Spaltenbreite wird nur für das aktuell
  End Sub bearbeitete Worksheet nach Zell-Eingabe
automatisch angepasst.
Tabellenblatt kopieren und für Sub Neues_Blatt_Anlegen()
dieses eine dreistellige fort- Dim wks As Worksheet, nme As Name, intNme%, strNme$
laufende Nummerierung For Each nme In ThisWorkbook.Names Bereits vergebene Namen dürfen sich auch
vergeben strNme = Right(nme.Name, 3) dann nicht wiederholen, wenn die Blätter
If Len(strNme) = 3 And IsNumeric(strNme) Then inzwischen gelöscht wurden.
If CInt(strNme) > intNme Then
intNme = CInt(strNme)
End If
End If
Next nme
With ThisWorkbook
.Worksheets(1).Copy after:=.Worksheets(.Worksheets.Count)
End With
ActiveSheet.Name = Format(intNme + 1, "000")
Set nme = ActiveWorkbook.Names.Add("wks" & _
Format(intNme + 1, "000"), Range("A1"), False)
nme.Visible = False
  End Sub  
Alle Zeilen ausblenden, wenn Sub Hide_All_Rows() In die Symbolleiste z.B. ein Icon einbinden,
Datum kleiner HEUTE ist Dim zeile%, zelle As Range mit dem man das Makro ständig ein- oder
zeile = 1 ausschalten kann. Startzeile (kann auch z.B.
Set zelle = ActiveSheet.Cells(zeile, 1) mit 5 beginnen). Startzelle = A1.
Do Until zelle(zeile, 1) = Date Makro ausführen, bis HEUTE in Spalte 1
If zelle(zeile, 1).Value <= Date And _ gefunden wird. Andere Möglichkeit:
Rows(zeile).EntireRow.Hidden = False Then ...Value < DateSerial(1999, 10, 30).
Rows(zeile).EntireRow.Hidden = True Alle Zeilen verstecken, bis HEUTE gefunden
Else wird.
Rows(zeile).EntireRow.Hidden = False Alle Zeilen wieder sichtbar machen.
End If
zeile = zeile + 1 Zeilenzähler.
Loop
zelle(zeile, 2).Select Am Schluss wird jene Zelle in der 2. Spalte
  End Sub selektiert, die in der HEUTE-Zeile steht.
Dateiname aus Zelle auslesen Sub Lies_Datei()
und Datei öffnen Workbooks.Open FileName:=[A1]
  End Sub  
Bei Eingabe in Zeile 2 Datum in Sub Worksheet_Change(ByVal Target As _
erste Zeile schreiben Excel.Range)
If Target.Row = 2 Then Cells(Target.Row - 1, _
Target.Column) = Date
  End Sub
Bei Eingabe in Spalte 2 Datum Sub Worksheet_Change(ByVal Target As _
und Zeit in Spalte 1 schreiben Excel.Range)
If Target.Column = 2 Then Cells(Target.Row, _
Target.Column - 1) = Now
  End Sub  
Dezimalzahlen mit Nachkomma- Sub einfuegen() Die Microsoft-Lösung:
stellen in Zellen schreiben Sheets(1).Cells(1, 2) = CDbl(InputBox.Text) Format(InputBox.Text, "##0.0000")
(z.B. aus Input-Box) End Sub bringt falsche Nachkommastellen.
Worksheet als neues Sub Blatt_kopieren()
Workbook speichern Dim wksQuell As Worksheet
Dim wkbQuell As Workbook
Dim wksZiel As Worksheet
Dim wkbZiel As Workbook
Set wkbQuell = ActiveWorkbook
Set wksQuell = ActiveSheet
wksQuell.Copy Das Blatt wird ohne Zielangabe kopiert, eine
Set wkbZiel = ActiveWorkbook neue Datei entsteht.
Set wksZiel = ActiveSheet
wksZiel.Cells(1, 1) = "Hallo"
wkbZiel.Close savechanges:=True
Set wkbZiel = Nothing Am Ende nicht vergessen, den Speicher wieder
Set wksZiel = Nothing frei zu geben.
Set wkbQuell = Nothing
Set wksQuell = Nothing
  End Sub  
Blockweise ganze Bereiche Durch voranstellen eines ' wird Code als Kommentar verstanden und grün angelegt.
auskommentieren Will man nicht nur eine Zeile auskommentieren, sondern einen ganzen Block, bietet Excel im VBA-Editor
im Menü Ansicht unter Symbolleisten die Option Bearbeiten.
In der befindet sich neben einem Icon mit einer erhobenen Hand ein Icon mit angedeutetem Text,
wobei ein Teil des Textes hellblau hervorgehoben ist. Drückt man nun diese Taste, wird der komplette
Code, den man zuvor ausgewählt hat, auskommentiert.
Rechts neben dem eben beschriebenen Icon befindet sich ein ähnliches, nur mit einem zusätzlichen
  kleinen Pfeil darüber. Mit diesem lässt sich die Kommentierung zurücknehmen.
Statt der WENN- die WAHL- Beispiel, wenn in Zelle A1 die Monatsnummer steht:
Funktion nutzen =WAHL(A1;"Januar";"Februar";"Marz";"April";"Mai";"Juni";"Juli";"August"; _
"September";"Oktober";"November";"Dezember")
  Darauf achten, dass beim Kopieren aus der Zwischenablage alle Zeichen mitgenommen werden.
Kommentare im Worksheet Sub cmdComment_Click() Auf dem Worksheet einen CommandButton
einheitlich formatieren Dim x As Comment platzieren.
For Each x In ActiveSheet.Comments Schleife im Worksheet.
With x.Shape.TextFrame.Characters.Font
.Name = "Arial" Schriftart.
.Size = 9 Schriftgröße.
.Bold = False Schriftformatierung.
End With
With x.Shape
.Width = 250 Größe des Kommentar-Fensters einheitlich.
.Height = 250
End With
Next x
Range("a1").Select
  End Sub  
Neue Kommentare im Work- Sub Kommentar_ohne_UserName()
sheet ohne UserName On Error Resume Next Fehler abfangen, falls bereits ein Kommentar
Dim x As Comment existiert.
ActiveCell.Select
Set x = ActiveCell.AddComment Kommentar eingabebereit machen (dann
x.Visible = True reinklicken und schreiben).
x.Text "" UserName löschen.
With x.Shape
.Width = 150 Größe des Kommentar-Fensters einheitlich.
.Height = 150
End With
With x.Shape.TextFrame.Characters.Font
.Name = "Arial" Schriftart.
.Size = 9 Schriftgröße.
.Bold = False Schriftformatierung.
End With
' x.Shape.TextFrame.AutoSize = True AutoSize lohnt sich nur bei kleinen
  End Sub Kommentaren.
Kommentare mit Worksheet- Im Menü Datei auf Seite einrichten klicken und dann auf die Registerkarte Tabelle. Um Kommentare
Inhalt ausdrucken am Ende des Tabellenblatts zu drucken, im Feld Kommentare auf "Am Ende des Blattes" klicken.
Um Kommentare so zu drucken, wie sie im Tabellenblatt angezeigt werden, im Feld Kommentare auf
  "Wie auf Blatt angezeigt" klicken.
Kopiert Daten von mehreren Sub Kopiere_Daten() Makro muss noch überarbeitet werden
Worksheets auf neues Dim i%, z%, c%, r%
Worksheet Application.ScreenUpdating = False
Worksheets.Add.Move After:=Worksheets(Worksheets.Count)
z = 0
For i = 1 To 4 Anzahl der Sheets, die kopiert werden sollen.
Cells(z + 1, 1) = "Blatt: " & Worksheets(i).Name Name für neues Sheet vergeben.
z = z + 2
With Worksheets(i)
r = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
c = .Cells.Find("*", [A1], , , xlByColumns, xlPrevious).Column
.Range(.Cells(1, 1), .Cells(r, c)).Copy
ActiveSheet.Paste Destination:=Range(Cells(z, 1), Cells(z + r - 1, c))
z = z + r + 2
End With
Next i
'Application.DisplayAlerts = False Excel sendet keine Fehlermeldungen.
Worksheets(Worksheets.Count).PrintPreview Druckvorschau.
'Application.DisplayAlerts = True True schaltet Meldungen wieder ein ("Soll
  End Sub wirklich gespeichert werden?")
Snapshoot mit "Kamera" aus Vorher müssen noch die Menge der Sheets, die Zellbereiche (Range),
gleichen Teilbereichen sowie die Abstände der einzelnen Snapshots angepasst werden.
mehrerer Sheets erzeugen Sub Drucke_Bereiche_aus_Mehreren_Sheets_auf_ein_Blatt()
Dim i%, r%
r = 1
For i = 2 To 4 Menge der Sheets, z. B. drei.
Worksheets(i).Range("A1:D10").CopyPicture _ Range: Bereich wählen.
Appearance:=xlScreen, Format:=xlBitmap
Vorher muss noch ein leeres Sheet erzeugt werden, auf dem die "Fotos" abgelegt werden können.
Worksheets("NeuesSheet").Paste Destination:= _ Sheetname wählen.
Worksheets("NeuesSheet").Cells(r, 1)
r = r + 8 Abstände der einzelnen Snapshots
Next i zueinander anpassen.
ActiveSheet.PrintPreview Druckvorschau.
  End Sub  
Umrechnung von Tabellen- Sub DM_Euro()
werten (von Euro in Const curs As Double = 1.95883 Konstante für Euro-Kurs.
Fremdwährung) Dim rng As Range
For Each rng In ActiveSheet.UsedRange.Cells Nur benutzter Zellenbereich wird verarbeitet.
If IsNumeric(rng.Value) = True And _ Wenn Inhalt numerisch ist UND
Not rng.Value = Empty And _ die Zelle nicht leer ist UND
Not rng.HasFormula Then die Zelle keine Formel enthält,
rng.Value = Application.Round(rng.Value / curs, 2) dann berechne den Wert neu.
End If
Next rng
  End Sub  
Zeichenlänge darf bestimmten Private Sub Worksheet_Change(ByVal Ziel As Range) Bei jeder Änderung des Worksheet-Inhalts
Wert nicht überschreiten On Error GoTo 10 wird geprüft.
If Ziel.Column = 1 Then Spalte 1 ist das Ziel.
If Len(Ziel) > 12 Then Hier ist die Länge des Zelleninhalts das Ziel.
MsgBox "Ungültig: Mehr als 12 Stellen!"
Ziel.Activate Zielzelle wieder aktivieren, um neue Eingabe
Ziel.Clear zu machen. Alter Wert wird gelöscht.
End If
End If
10
  End Sub  
Hochkomma im Excel-Sheet Sub AddTicks()
hinzufügen Dim LastPlace, Z As Variant, X As Variant
Sheets("Sheet1").Select Name des Excel-Sheets.
LastPlace = ActiveCell.SpecialCells(xlLastCell).Address
ActiveSheet.Range(Cells(1, 1), LastPlace).Select
Z = Selection.Address Zellenbereich ansprechen (vorher selektieren?).
For Each X In ActiveSheet.Range(Z)
If Len(X) > 0 Then Nur Zellen, wo was drin steht, ansprechen.
X.FormulaR1C1 = Chr(39) & X.Text 39 ist der Code für das Hochkomma.
Else
X.FormulaR1C1 = "" Leere Zellen überspringen.
End If
Next
  End Sub  
Excel-Diagramm als Grafik Sub procDiagrammExportieren() Ab Excel 97
exportieren Dim strGrafikName As String Dieser Prozedur einer Schaltfläche zuweisen,
strGrafikName = Application.GetSaveAsFilename _ Diagramm markieren und über
("diagramm", FileFilter:="GIF-Format (*.gif)," & _ Schaltflächenklick speichern.
" *.gif,JPG-Format (*.jpg), *.jpg")
On Error GoTo ErrorHandler oder:
ActiveChart.Export Filename:=strGrafikName, _ ActiveChart.Export FileName:="c:\Mychart.gif", _
FilterName:=Right(strGrafikName, 3) FilterName:="GIF"
Exit Sub
ErrorHandler:
If Err.Number = 91 Then
  MsgBox "Export nicht möglich. " & "Kein Diagramm ausgewählt.", _
vbCritical + vbOKOnly, "Diagramm als Grafik exportieren"
Else
  MsgBox "Fehler: " & Err.Number & " - " & Err.Description, _
vbCritical + vbOKOnly, "Diagramm als Grafik exportieren"
End If
  End Sub  
Letztes Speicherdatum in Zelle Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
schreiben Cancel As Boolean)
Range("A1").Value = Date & " " & Time Datum wird vor Speichern in eine Zelle
  End Sub geschrieben.
Seitenanzahl feststellen Sub pagecount()
Dim page_count As Integer
page_count = (ActiveSheet.HPageBreaks.Count + 1) * _
(ActiveSheet.VPageBreaks.Count + 1)
MsgBox page_count & " Seiten"
  End Sub  
Verbinden und Zentrieren von Private Declare Function GetKeyState% Lib "user32" (ByVal vkey As Long)
Zellen per Schaltfläche Sub VerbindenUndZentrieren() Per Mausklick markierte Zellen verbinden
If Abs(GetKeyState(16) < 0) Then und zentrieren.
Selection.MergeCells = False Wird das Symbol bei gedrückter Umschalt-
Else Taste angeklickt, wird die Verbindung
Selection.MergeCells = True rückgängig gemacht.
End If
  End Sub  
Zirkelbezüge automatisch Sub ZirkelbezuegeAuflisten() Wertvolle Hilfe bei Fehlersuche in umfang-
auflisten   Set AktBlatt = ActiveSheet reichen Kalkulationen:
  Sheets.Add Nachdem man auf eine beliebige Zelle innerhalb
  Set NeuesBlatt = ActiveSheet der Tabelle geklickt und das Makro gestartet hat,
  Zielbereich = ActiveCell.Address wird ein neues Arbeitsblatt erzeugt, in dem alle
  AktBlatt.Activate Zellen mit Zirkelbezügen sowie den
  Zeilenzähler = 0 entsprechenden Formeln aufgeführt sind.
  On Error GoTo MakroNeuAufnehmen Jede Zelle des aktiven Bereiches (UsedRange)
  For Each Zelle In AktBlatt.UsedRange wird überprüft, ob sie eine Formel enthält
    If Left(Zelle.Formula, 1) = "=" Then oder nicht..
    Ergebnis = Intersect(AktBlatt.Range(Zelle.Address), _
AktBlatt.Range(Zelle.Precedents.Address))
    NeuesBlatt.Range(Zielbereich).Offset(Zeilenzähler, 0).Value = _
Zelle.Address(False, False)
    NeuesBlatt.Range(Zielbereich).Offset(Zeilenzähler, 1).Value = _
" " & Zelle.Formula
    Zeilenzähler = Zeilenzähler + 1
Weiter:
    End If
  Next
Exit Sub
MakroNeuAufnehmen:
  Resume Weiter
  End Sub  
Kopieren von geschützten Private Sub Workbook_Open() Ab Excel 2002 nicht mehr gültig!
Bereichen verhindern  Worksheets("Verkäufe Jan").EnableSelection = _ Die Namen der Worksheets müssen exakt
xlUnlockedCells angegeben werden.
 Worksheets("Mustertabelle 541").EnableSelection = _ Das Makro wird bei Öffnen der Arbeitsmappe
xlUnlockedCells ausgeführt.
  End Sub  
Arbeitsmappe per Mail auto- Public Sub procDateiPerMail() Makro einer Schaltfläche zuweisen,
matisch verschicken Dim astrMailEmpfaenger(2) As String
  If Application.MailSystem <> xlNoMailSystem Then
    astrMailEmpfaenger(1) = "hans@mustermann.de" Array von Empfängern.
    astrMailEmpfaenger(2) = "test@test.de"
    Application.ActiveWorkbook.SendMail astrMailEmpfaenger(), _
"Aktuelle Umsatzstatistik", False
  End If
  End Sub  
Automatische Makros per VBA Workbooks.Open "BUDGET.XLS" Aus Workbook_1 das Workbook_2 aufrufen.
kontrollieren ActiveWorkbook.RunAutoMacros xlAutoOpen Die Makros in Workbook_2 werden jedoch nur
gestartet, wenn man RunAutoMacros aufruft.
ActiveWorkbook.Close Vor dem Schließen von Workbook_2 die
  ActiveWorkbook.RunAutoMacros xlAutoClose Makros deaktivieren.
Spalten / Zeilen Farben zuweisen Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, _
Dynamischer Mauszeiger ByVal Target As Excel.Range)
Dim c%, p$, w$, r$, colr%, pw$
Static AlteZelle As Range Die vorherig markierte Zelle merkt man sich.
pw = "5g#h5?1g6*4n7ßen1n§%b"
ActiveSheet.Unprotect (pw) Passwort entfernen.
Application.StatusBar = "" Alte Statusbar-Meldung entfernen.
colr = 0 Farbzähler zurücksetzen.
If Not AlteZelle Is Nothing Then
AlteZelle.EntireRow.Interior.ColorIndex = _ Wenn ein alter Eintrag markiert war, die Farbe
xlColorIndexNone zurücksetzen. Row = Zeile; Column = Spalte.
AlteZelle.EntireColumn.Interior.ColorIndex = _
xlColorIndexNone
End If
Target.EntireRow.Interior.ColorIndex = 20 Die neu markierte Zelle erhält die Farbe blau.
r = Left(Target.Address, 2) Zelladresse wird als Teilstring ausgelesen.
p = Left(Target.Address, 3) Zelladresse wird als Teilstring ausgelesen.
If r = "$C" Then Wenn Spalte C.
Do Schleifenverarbeitung (für die Spalte C) beginnt.
c = c + 1 Schleifenzähler; oder früherer Abbruch, wenn OK.
w = p & c Die Zelladresse wird zusammengebaut.
If Target.Address = w Then Wenn tatsächliche Zelladresse = gebaute
Randomize Zelladresse.
colr = Int((56 * Rnd) + 1) Farbe wird zufällig erzeugt (1 bis 56 möglich)
Target.EntireColumn.Interior.ColorIndex = colr Die Spalte wird gefärbt.
Exit Do Bedingung erfüllt, also raus aus der Schleife.
End If
Loop Until c = 4514 Die Tabelle hat hier 4514 Zeilen.
End If
Set AlteZelle = Target Die vorherig markierte Zelle wird "entfärbt".
If colr > 0 Then Meldung Statusbar über markierte Zellen.
Application.StatusBar = "Zellposition: " & Target.Address & " " _
& "Colour: " & colr
Else
Application.StatusBar = "Zellposition: " & Target.Address & " " _
& "Colour: " & 20
End If
ActiveSheet.Protect (pw) Passwort wieder setzen.
  End Sub  
Userform mit Worksheet immer Sub showform() Ein Modul startet das Formular (VBA kennt keinen
anzeigen UserForm1.Show vbModeless FormLoad-Befehl). vbModeless bewirkt, dass
End Sub gleichzeitig mit Userform und Worksheet
    gearbeitet werden kann.
Prüfung, ob Datei existiert Private Function FileExists(fname) As Boolean
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True _
Else FileExists = False
  End Function  
Dateinamen aus String "Pfad" Private Function FileNameOnly(pname) As String
und "Dateiname" extrahieren Dim i As Integer, length As Integer, temp As String
length = Len(pname)
temp = ""
For i = length To 1 Step -1
If Mid(pname, i, 1) = Application.PathSeparator Then
FileNameOnly = temp
Exit Function
End If
temp = Mid(pname, i, 1) & temp
Next i
FileNameOnly = pname
  End Function  
Prüfung, ob Pfad existiert Private Function PathExists(pname) As Boolean
Dim x As String
On Error Resume Next
x = GetAttr(pname) And 0
If Err = 0 Then PathExists = True _
Else PathExists = False
  End Function  
Prüfung, ob Workbook existiert Private Function RangeNameExists(nname) As Boolean
Dim n As Name
RangeNameExists = False
For Each n In ActiveWorkbook.Names
If UCase(n.Name) = UCase(nname) Then
RangeNameExists = True
Exit Function
End If
Next n
  End Function  
Prüfung, ob Worksheet im Private Function SheetExists(sname) As Boolean
aktiven Workbook existiert Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
  End Function  
Prüfung, ob Workbook Private Function WorkbookIsOpen(wbname) As Boolean
geöffnet ist Dim x As Workbook
On Error Resume Next
Set x = Workbooks(wbname)
If Err = 0 Then WorkbookIsOpen = True _
Else WorkbookIsOpen = False
  End Function  
Alle Zeilen löschen, wenn Sub PruefenLoeschen()
Datum kleiner Heute ist Dim intCounter As Integer, intLastRow As Integer
intLastRow = Cells(Rows.Count, 6).End(xlUp).Row
For intCounter = intLastRow To 1 Step -1
If Not IsEmpty(Cells(intCounter, 6)) And _
CDbl(Cells(intCounter, 6).Value) < CDbl(Date) Then
Rows(intCounter).Delete
End If
Next intCounter
  End Sub  
Benutzerdefinierte Namen in Sub BenutzerdefinierteNamenLoeschen()
Workbook löschen Dim definedName As Object
For Each definedName In ActiveWorkbook.Names
definedName.Delete
Next
  End Sub  
Selektieren, Aktivieren... Selection.NumberFormat = "### ###-####" Nummerformat z.B. 123 456-7890 (in Spalte M).
LastRow = Application.CountA(ActiveSheet. _ Zeilen-Nr. der letzten aneinander grenzenden
Range("M:M")) Zellen.
Application.Union(Cells(i, 1), Cells(i, 10), _ Gruppe von nicht angrenzenden Zellen selektieren.
Cells(i, 4)).Select
Windows("Phone List.xls").Activate Datei aus Excel öffnen.
STOP Stop-Kommando bei AutoExec-Makros (zum
ActiveWorkbook.SendMail "user@domain.com", _ Debuggen). Workbook via email senden.
"Message Subject", Null
BottomRw = ActiveCell.SpecialCells(xlLastCell).Row Zeilennummer der letzten benutzten Zelle lesen.
  Sheets(Array(3, 4, 6, 7, 9, 10, 12)).Select Nur bestimmte Worksheets selektieren.
Groß-/Kleinschreibung in Sub SwitchCase()
Zellen ändern Dim C As Range
For Each C In Selection
Select Case C
Case LCase(C) Wenn nur kleinbuchstaben.
C = UCase(C) Wandelt in GROSSBUCHSTABEN.
Case UCase(C) Wenn nur GROSSBUCHSTABEN.
C = Application.Proper(C) Wandelt in Groß_klein.
Case Else Wenn gemischt Groß_klein.
C = LCase(C) Wandelt in kleinbuchstaben.
End Select
Next
  End Sub  
WAV-Datei bei Doppelklick auf Private Sub Worksheet_BeforeDoubleClick(ByVal _ Pfade und Dateinamen in Tabelle (Zellen)
Zelle abspielen Target As Range, Cancel As Boolean) ablegen (z.B. C:\Jazz\Music.wav).
If Target.Column <> 1 Then Exit Sub Column = Nummer der Spalte.
If IsEmpty(Target) Then Exit Sub
Cancel = True
If Dir(Target.Value) = "" Then Exit Sub
Call sndPlaySound32(Target.Value, 1)
End Sub
Declare Function sndPlaySound32 Lib "winmm.dll" _ Diese Funktion in ein Modul einbinden.
Alias "sndPlaySoundA" (ByVal lpszSoundName _
  As String, ByVal uFlags As Long) As Long  
Markierte Worksheets Sub Markierte_Worksheets_Ausblenden()
ausblenden On Error GoTo ende
ActiveWindow.SelectedSheets.Visible = False
ende:
Exit Sub
  End Sub  
Alle Worksheets einblenden Sub Alle_Worksheets_Einblenden()
Dim i%
On Error GoTo ende
For i = 1 To Sheets.Count
Sheets(i).Visible = True
Next
ende:
Exit Sub
  End Sub  
Prüfen, ob nur eine Zelle Sub Worksheet_SelectionChange(ByVal Target As Range)
selektiert wurde Dim testcell As Range, y#
y = 0 Prüfung vor Verarbeitung sinnvoll, wenn die
For Each testcell In Selection weitere Verarbeitung nur eine bestimmte
y = y + 1 Zelle betrifft.
If y > 1 Then Exit Sub Falls man versehenlich das ganze Sheet
Next testcell markiert, kann (ohne diese Prüfung) Excel
If Not Application.Intersect(Target, Range("B:B")) Is Nothing Then
...mach irgendwas... abstürzen.
End If
  End Sub  
Computer- & Username & Private Declare Function GetComputerNameA Lib "kernel32" _
Autor eines Workbooks (ByVal lpBuffer As String, nSize As Long) As Long
ermitteln Private Declare Function GetUserNameA Lib "advapi32.dll" _
(ByVal lpBuffer As String, nSize As Long) As Long
Function WhereAmI() As String
Dim s As String * 255
GetComputerNameA s, Len(s)
WhereAmI = Left$(s, InStr(s, vbNullChar) - 1)
End Function
Function WhoAmI() As String
Dim s As String * 255
GetUserNameA s, Len(s)
WhoAmI = Left$(s, InStr(s, vbNullChar) - 1)
End Function
Sub GetNam()
If LCase(WhoAmI) <> _
LCase(ThisWorkbook.BuiltinDocumentProperties(3)) Then Exit Sub
MsgBox LCase(WhereAmI) & LCase(WhoAmI) Computer- & Username
MsgBox LCase(ThisWorkbook. _ Autor des Workbooks
BuiltinDocumentProperties(3))
  End Sub  
Entfernt Dateiendung Sub DatTest()
Dim DatName$, DName$, DEnde$, Z&, Zeichen$
DatName = "hallo.xxl\"
For Z = Len(DatName) To 1 Step -1
Zeichen = Mid(DatName, Z, 1) 'x-ten Buchstaben von hinten
If Zeichen = "." Then 'Punkt gefunden
DName = Left(DatName, Z - 1)
DEnde = Right(DatName, Len(DatName) - Z)
Exit For
ElseIf Zeichen = "\" Then 'Sollte das Zeichen ein "\" sein
DName = Left(DatName, Z - 1)
End If
Next Z
MsgBox DName
  End Sub  
Endlosschleifen mit Escape Private Declare Function GetAsyncKeyState Lib "user32" _
abbrechen (ByVal vKey As Long) As Integer
Sub LoopEscape()
Do
DoEvents
If (GetAsyncKeyState(&H1B)) <> 0 Then Exit Do
Loop Until 1 = 2
  End Sub  
Grafiken löschen Sub Loesche()
Dim bild As Shape
For Each bild In ThisWorkbook.Worksheets(1).Shapes()
bild.Delete
Next bild
End Sub
Sub Loesche()
Dim i&
For i = 0 To Shapes.Count -1
Shapes(i).Delete
Next i
End Sub
Sub Loesche_Grafik_in_bestimmten_Bereich()
Dim bild As Shape
For Each bild In ActiveSheet.Shapes
If bild.Top < [e20].Top And bild.Left < [e20].Left Then bild.Delete
Next bild
  End Sub  
Zählt sichtbare Zeilen und Sub Zaehlen()
Spalten, die Werte enthalten Dim iRow%, iCol%, iRowL%, iColL%, iCounter%
iRowL = Cells(Rows.Count, 1).End(xlUp).Row
For iRow = 1 To iRowL
If Rows(iRow).Hidden = False Then
If WorksheetFunction.CountA(Rows(iRow)) > 0 Then
iCounter = iCounter + 1
End If
End If
Next iRow
Range("A1").Value = iCounter
iCounter = 0
iColL = Cells(1, 256).End(xlToLeft).Column
For iCol = 1 To iColL
If Columns(iCol).Hidden = False Then
If WorksheetFunction.CountA(Columns(iCol)) > 0 Then
iCounter = iCounter + 1
End If
End If
Next iCol
Range("B1").Value = iCounter
  End Sub  
Pivot-Tabellen aktualisieren Sub Worksheet_Activate() Makro ins Worksheet einbinden, in der sich die
(mehrere auf einem Sheet) PivotRefresh Pivot-Tabellen befinden.
End Sub
Sub PivotRefresh()
Dim WB As Worksheet, piv%, i%
Set WB = ThisWorkbook.Worksheets("Pivot")
piv = WB.PivotTables.Count Pivots zählen.
For i = 1 To piv
WB.PivotTables(i).PivotCache. _ Automatisches Refresh aktivieren.
RefreshOnFileOpen = True
WB.PivotTables(i).PivotCache.Refresh und Refresh, wenn Worksheet aktiviert wird.
VBA.DoEvents
Next
Set WB = Nothing
  End Sub  
VBA-Makros Excel
Sponsoren und Investoren

Sponsoren und Investoren sind jederzeit herzlich willkommen!
Wenn Sie die Information(en) auf dieser Seite interessant fanden, freuen wir uns über eine kleine Spende. Empfehlen Sie uns bitte auch in Ihren Netzwerken (z. B. Twitter, Facebook oder Google+). Herzlichen Dank!

Nach oben Sitemap
Impressum & Kontakt