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 inclusive 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 ExcelDateienZählen()
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:
	Cancel = True	If CloseMode <> 1 Then Cancel = 1
Schließen verhindert werden	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