| 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 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 | |
| | |
zurück