| Sammlung diverser Makros | |
| | |
| | |
| Blattschutz durch Makro | Sub SchutzAusEin() | |
| aus- und einschalten | ActiveSheet.Unprotect "Test" | |
| MsgBox "Blattschutz ist aufgehoben!" | |
| ActiveSheet.Protect "Test" | |
| MsgBox "Blattschutz ist gesetzt!" | |
| | End Sub | |
| Tastatureingaben | Sub Auto_Open() | |
| abfangen | Application.OnKey "%{F8}", "TueDiesUndDas" | |
| End Sub | |
| Sub TueDiesUndDas() | |
| MsgBox ActiveCell.Address | |
| | End Sub | |
| Excel-Version auslesen | Function fGetExcelVer() As Integer | |
| If Application.Version Like "*5*" Then | |
| fGetExcelVer = 5 | |
| ElseIf Application.Version Like "*7*" Then | |
| fGetExcelVer = 7 | |
| Else | |
| fGetExcelVer = 8 | |
| End If | |
| End Function | |
| Sub PerVersion() | |
| MsgBox Application.Version | |
| Select Case Left(Application.Version, 1) | |
| Case "5" | |
| MsgBox "Sie verwenden Excel 5" | |
| Case "7" | |
| MsgBox "Sie verwenden Excel 7/95" | |
| Case "8" | |
| MsgBox "Sie verwenden Excel 8/97" | |
| Case Else | |
| MsgBox "Sie verwenden eine unbekannte Excel-Version" |
| End Select | |
| ThisWorkbook.Activate | |
| | End Sub | |
| Kalenderwoche berechnen | Function DKW(dat As Date) As Integer | |
| Dim a As Integer | |
| a = Int((dat - DateSerial(Year(dat), 1, 1) + ((WeekDay(DateSerial(Year(dat), 1, 1)) + 1) Mod 7) - 3) / 7) + 1 |
| If a = 0 Then | |
| a = DKW(DateSerial(Year(dat) - 1, 12, 31)) | |
| ElseIf a = 53 And (WeekDay(DateSerial(Year(dat), 12, 31)) - 1) Mod 7 <= 3 Then |
| a = 1 | |
| End If | |
| DKW = a | |
| End Function | |
| Function KWoche(d As Date) As Integer | |
| Dim t& | |
| t = DateSerial(Year(d + (8 - WeekDay(d)) Mod 7 - 3), 1, 1) |
| KWoche = (d - t - 3 + (WeekDay(t) + 1) Mod 7) \ 7 + 1 | |
| | End Function | |
| Stellenzahl auslesen | Function CountDigits(s As String) As Integer | |
| Dim i | |
| For i = 1 To Len(s) | |
| If Mid(s, i, 1) Like "#" Then | |
| CountDigits = CountDigits + 1 | |
| End If | |
| Next i | |
| | End Function | |
| Benutzernamen anzeigen | Sub FensterName() | |
| ActiveWindow.Caption = ActiveWindow.Caption & " " _ | Username aus Excel |
| & Application.UserName | |
| MsgBox Environ("USERNAME") | Username des Betriebssystems |
| | End Sub | |
| Excel-Titelzeile ändern | Sub TitelWechseln() | |
| Application.Caption = "Veränderte Titelleiste" | |
| | End Sub | |
| CSV-Datei schreiben | Sub Write_Csv() | |
| F = FreeFile(0) | |
| fname = InputBox("Enter the filename with Path:", "Please Enter Output File Name:") |
| MsgBox "File Selected is: " & fname | |
| If fname <> False Then | |
| Open fname For Output As #F | |
| Set Rng = ActiveCell.CurrentRegion | |
| Debug.Print Rng.Address | |
| FCol = Rng.Columns(1).Column | |
| LCol = Rng.Columns(Rng.Columns.Count).Column | |
| Frow = Rng.Rows(1).Row | |
| Lrow = Rng.Rows(Rng.Rows.Count).Row | |
| For i = Frow To Lrow | |
| outputLine = "" | |
| For j = FCol To LCol | |
| If j <> LCol Then | |
| outputLine = outputLine & Cells(i, j) & ";" | Semikolon als Texttrennzeichen, kann |
| Else | geändert werden |
| outputLine = outputLine & Cells(i, j) | |
| End If | |
| Next j | |
| Print #F, outputLine | |
| Next i | |
| Close #F | |
| End If | |
| End Sub | |
| Sub schreibeCSV() | |
| F = FreeFile(0) | |
| fname = InputBox("Bitte Pfad und Dateinamen der Zieldatei eingeben (z.B. c:\tmp\text.csv):", _ |
| "Eingabe Pfad und Dateiname") |
| MsgBox "Der Name der Ausgabedatei lautet: " & fname |
| fseparator = InputBox("Bitte das Trennzeichen eingeben:", "Eingabe Trennzeichen") |
| MsgBox "Das gewählte Trennzeichen ist: " & fseparator | |
| If fname <> False Then | |
| Open fname For Output As #F | |
| Set Rng = ActiveCell.CurrentRegion | |
| Debug.Print Rng.Address | |
| FCol = Rng.Columns(1).Column | |
| LCol = Rng.Columns(Rng.Columns.Count).Column | |
| Frow = Rng.Rows(1).Row | |
| Lrow = Rng.Rows(Rng.Rows.Count).Row | |
| For i = Frow To Lrow | |
| outputLine = "" | |
| For j = FCol To LCol | |
| If j <> LCol Then | |
| outputLine = outputLine & Cells(i, j) & fseparator | |
| Else | |
| outputLine = outputLine & Cells(i, j) | |
| End If | |
| Next j | |
| Print #F, outputLine | |
| Next i | |
| Close #F | |
| End If | |
| MsgBox "Vorgang abgeschlossen!" | |
| | End Sub | |
| Zellen nach Datenimport | Dim Cell As Range | |
| aufbereiten | Sub DatenUmwandeln() | |
| Dim MyRange As Range | |
| Application.ScreenUpdating = False | |
| Set MyRange = ActiveCell.CurrentRegion.Columns(7) | |
| For Each Cell In MyRange | |
| Cell.Select | |
| Application.SendKeys "{F2}+{ENTER}", True | |
| Next Cell | |
| End Sub | |
| Sub ZellenAufbereiten() | |
| For Each Cell In Selection | |
| Cell.Select | |
| Application.SendKeys "{F2}+{ENTER}", True | |
| Next | |
| | End Sub | |
| Existenz einer Datei prüfen | Function FileExist(Filename As String) As Boolean | |
| On Error GoTo HandleError | |
| FileExist = False | |
| If Len(Filename) > 0 Then FileExist = (Dir(Filename) <> "") | |
| Exit Function | |
| HandleError: | |
| FileExist = False | |
| If (Err = 1005) Then | |
| MsgBox "Error - printer missing" | |
| Resume Next | |
| Else | |
| If (Err = 68) Or (Err = 76) Then | |
| MsgBox "Unit or Path do not exist: " & Filename, vbExclamation |
| Resume Next | |
| Else | |
| MsgBox "Unexpected error " & Str(Err) & " : " & | |
| Error(Err), vbCritical | |
| End | |
| End If | |
| End If | |
| | End Function | |
| Datei löschen | Sub DelFile() | |
| If Len(Dir("c:\windows\test.txt")) > 0 Then | |
| Kill "c:\windows\test.txt" | |
| MsgBox "Test.txt has been killed" | |
| Else | |
| MsgBox "Test.Txt never existed" | |
| End If | |
| | End Sub | |
| Daten nach Access | Sub TestAdd() | |
| senden | Dim db As Database, rs As Recordset | |
| Set db = OpenDatabase("C:\Test.mdb") | |
| Set rs = db.OpenRecordset(Name:="Test", Type:=dbOpenDynaset) |
| With rs | |
| .AddNew | |
| .Fields("Name").Value = Range("A1") | |
| .Fields("Alter").Value = Range("A2") | |
| .Update | |
| End With | |
| rs.Close | |
| db.Close | |
| Set rs = Nothing | |
| | End Sub | |
| Mappe mit Dateinamen | Sub Auto_Close() 'unter Namen speichern, welcher in Zelle A1 steht |
| aus Zelle speichern | Dim f As String; r As Integer | |
| f = ThisWorkbook.Sheets(1).Cells(1; 1).Value | |
| If f = "" Then | |
| f = Application.GetSaveAsFilename(fileFilter:="Excel Workbook(*.xls), *.xls") |
| If f = False Then | |
| Exit Sub | |
| End If | |
| End If | |
| r = ThisWorkbook.Sheets(1).Cells(1; 1).Characters.Count |
| If ThisWorkbook.Sheets(1).Cells(1; 1).Characters(r - 3).Text <> ".xls" Then |
| f = f & ".xls" | |
| End If | |
| ThisWorkbook.SaveAs Filename:=f | |
| | End Sub | |
| Datei öffnen - Menü mit | Sub DateiAuswahl() | |
| definiertem Pfad starten | Dim WB As Workbook, TB As Worksheet | |
| Dim i%, dName, dFilter$ | |
| dFilter = "Excel-Dateien(*.xls), *.xls" | |
| ChDrive "d" | |
| ChDir "d:\MeineDatenl" | |
| dName = Application.GetOpenFilename(dFilter) | |
| If dName = False Then Exit Sub | |
| Set WB = Workbooks.Open(dName) | |
| Set TB = WB.Worksheets(1) | |
| For i = 1 To 20 | |
| TB.Cells(i, 5) = "Spalte E - Zeile " & i | |
| Next i | |
| | End Sub | |
| Datum als Dateiname | Sub DateAsFilename() | |
| Dim sFileName As String | |
| sFileName = Format(Now, "mmddyy") + ".xls" | |
| ActiveWorkbook.SaveAs sFileName | |
| | End Sub | |
| Schließen eines Dialog- | Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) |
| fensters verhindern | If CloseMode <> 1 Then Cancel = 1 | Prevent user from closing with the Close |
| | End Sub | Box in the title bar. |
| Kommentare per | Sub KommentarSchrift() | |
| Makro formatieren | Dim Cmt As Comment | |
| Set Cmt = ActiveCell.AddComment | |
| Cmt.Text "Mein Kommentar" | |
| With Cmt.Shape.TextFrame.Characters.Font | |
| .Name = "Arial" | |
| .Size = 14 | |
| End With | |
| | End Sub | |
| Zellbereich mit | Sub KommentarFestlegen() | |
| Kommentar versehen | Dim C As Range | |
| For Each C In Selection | |
| If Not C.Comment Is Nothing Then | |
| C.NoteText "Kommentar!" | |
| End If | |
| Next C | |
| | End Sub | |
| Größe des | Sub Kommentargrösse() | |
| Kommentarfensters | Dim Kommentarzelle As Range | |
| automatisch | Application.DisplayCommentIndicator = xlCommentAndIndicator |
| festlegen | For Each Kommentarzelle In ActiveSheet.Cells.SpecialCells(1) |
| Kommentarzelle.Comment.Shape.Select True | |
| Selection.AutoSize = True | |
| 'Selection.ShapeRange.Width = 150 | |
| 'Selection.ShapeRange.Height = 100 | |
| Next Application.DisplayCommentIndicator = xlCommentIndicatorOnly |
| | End Sub | |
| Makroausführung | Sub Pause() | |
| pausieren | Application.OnTime Now+TimeValue("00:00:01"), "Warten" |
| End Sub | |
| Sub Warten() | |
| MsgBox "Die Warterei beginnt beim OK !" | |
| NeueStunde = Hour(Now()) | |
| NeueMinute = Minute(Now()) | |
| NeueSekunde = Second(Now()) + 10 | |
| WarteZeit = TimeSerial(NeueStunde, NeueMinute, NeueSekunde) |
| Application.Wait WarteZeit | |
| MsgBox "Geschafft! 10 Sekunden sind um." | |
| | End Sub | |
| Makro durch | Private Sub Worksheet_Change(ByVal Target As Excel.Range) |
| Veränderung einer | If Target.Address = "$A$1" Or Target.Address = "$A$3" |
| Zelle starten | Then | |
| If Range("A1").Value < Range("A3").Value Then | |
| Macro1 | |
| End If | |
| End If | |
| End Sub | |
| Private Worksheet_Calculate() | |
| If Range("A1").Value < Range("A3").Value Then | |
| Macro1 | |
| End If | |
| End Sub | |
| Private Sub Worksheet_Change(ByVal Target As Excel.Range) |
| Dim Schnittpunkt As Range | |
| Set Schnittpunkt = Application.Intersect(Target, Me.Range("A1:A20")) |
| If Schnittpunkt Is Nothing Then | |
| Exit Sub | |
| Else | |
| MsgBox "Jetzt sollte das Makro ausgeführt werden" | |
| End If | |
| | End Sub | |
| Makroausführung | Sub Screen() | |
| verbergen | Application.ScreenUpdating=False | |
| ’Dazwischen läuft das Programm ab... | |
| Application.ScreenUpdating=True | |
| | End Sub | |
| Makroausführung: | Sub Abbruch() | |
| Unterbrechen | Application.EnableCancelKey = xlDisabled | |
| verhindern | End Sub | |
| Sub Abbruch() | |
| Application.EnableCancelKey = xlErrorHandler | |
| | End Sub | |
| Makroausführung | Application.OnEntry = "MeinMakro" | Dieser Code arbeitet global in allen geöffneten |
| nach jeder Eingabe | Application.OnEntry = "" | Mappen und Tabellen. |
| Makro nicht durch | Application.DisplayAlerts = False | Diese Zeile in der ersten Zeile des Makros |
| Sicherheitsabfragen | | |
| unterbrechen | | eintragen. |
| Makrounterbrechung | On Error GoTo EH | |
| abfangen | Application.EnableCancelKey = xlErrorHandler | |
| While 1 = 1 'Schleife | |
| X = X 'Schleife | |
| Wend 'Schleife | |
| Exit Sub | |
| EH: | |
| MsgBox "Break Key Hit" | |
| | Application.EnableCancelKey = xlInterrupt | |
| Makros und Code | Sub OpenProzedurAnlegen() | |
| dynamisch erstellen | Dim nWB As Workbook | |
| Dim mdlWB As Object | |
| Set nWB = Workbooks.Add | |
| Set mdlWB = nWB.VBProject.VBComponents("DieseArbeitsmappe") |
| With mdlWB.CodeModule | |
| .InsertLines 3, "Private Sub Workbook_Open()" | |
| .InsertLines 4, " Msgbox ""Bin jetzt da!""" | |
| .InsertLines 5, "End Sub" | |
| End With | |
| End Sub | |
| Sub Loeschen() | |
| With Workbooks("test.xls").VBProject | |
| .VBComponents.Remove .VBComponents("Modul1") |
| End With | |
| | End Sub | |
| Untermenüs (in | Sub MenuErstellen() | |
| Symbolleiste) durch | Dim MB As CommandBar | |
| Makro erstellen | Dim Ctrl1 As CommandBarControl | |
| Dim Ctrl2 As CommandBarControl | |
| Dim Ctrl1a As CommandBarControl | |
| Dim Ctrl1b As CommandBarControl | |
| Set MB = CommandBars.Add(Name:="Neues Menü", MenuBar:=True) |
| Set Ctrl1 = MB.Controls.Add(Type:=msoControlPopup) |
| Ctrl1.Caption = "Untermenü1" |
| Set Ctrl2 = MB.Controls.Add(Type:=msoControlPopup) |
| Ctrl2.Caption = "Untermenü2" |
| Set Ctrl1a = Ctrl1.Controls.Add(Type:=msoControlPopup) |
| Ctrl1a.Caption = "Daten" |
| Set Ctrl1b = Ctrl1.Controls.Add(Type:=msoControlPopup) |
| Ctrl1b.Caption = "Übertragen" | |
| CommandBars("Neues Menü").Visible = True | |
| | End Sub | |
| Menü "Symbolleisten" | Sub DisableToolbarMenu() | |
| de/aktivieren | CommandBars("Toolbar List").Enabled = False | |
| End Sub | |
| Sub DisableToolbarMenu() | |
| CommandBars("Toolbar List").Enabled = True | |
| | End Sub | |
| Menüs dynamisch | Private Sub Workbook_Activate() | |
| ein- und ausblenden | MenuBars(xlWorksheet).Menus.Add "&Test Menü" | |
| Set ml = MenuBars(xlWorksheet).Menus("Test Menü") |
| With ml | |
| .MenuItems.Add Caption:="&Daten erfassen", OnAction:="DatenSpeichern" |
| .MenuItems.AddMenu Caption:="&Auswertungen" | |
| With .MenuItems("Auswertungen") | |
| .MenuItems.Add Caption:="&Auswertung1", OnAction:="" |
| .MenuItems.Add Caption:="A&uswertung2", OnAction:="" |
| End With | |
| End With | |
| End Sub | |
| Private Sub Workbook_Deactivate() | |
| MenuBars(xlWorksheet).Reset | |
| End Sub | |
| Private Sub Workbook_Open() | |
| MenuBars(xlWorksheet).Menus.Add "&Test Menü" |
| Set ml = MenuBars(xlWorksheet).Menus("Test Menü") |
| With ml |
| .MenuItems.Add Caption:="&Daten erfassen", OnAction:="DatenSpeichern" |
| .MenuItems.AddMenu Caption:="&Auswertungen" |
| With .MenuItems("Auswertungen") |
| .MenuItems.Add Caption:="&Auswertung1", OnAction:="" |
| .MenuItems.Add Caption:="A&uswertung2", OnAction:="" |
| End With | |
| End With | |
| | End Sub | |
| Symbolleisten | Sub Verstecken() | |
| ausblenden | For Each tb in Toolbars | |
| tb.Visible = False | |
| Next tb | |
| | End Sub | |
| Shortcut-Menü ein- | Sub ShortCutOnOff() | |
| und ausschalten | Application.ShortcutMenus(xlWorksheetCell).Enabled = False |
| | End Sub | |
| Symbolleiste: | Sub SymbolGrauen() | |
| Icons deaktivieren | CommandBars("Standard").Controls(1).Enabled = False |
| | End Sub | |
| Symbolleiste | Sub NeueSymbolleiste() | |
| positionieren | Dim cmdB As CommandBar | |
| et cmdB = CommandBars.Add("MyToolbar", temporary:=True) |
| With cmdB | |
| .Left = 50 | |
| .Top = 100 | |
| .Visible = True | |
| End With | |
| | End Sub | |
| ID von Symbolleisten | ’Drei verschiedene Makros können verwendet werden: | |
| und Symbolen | ’CommandBarControlID_List liefert die IDs der Symbolleisten mit Menüpunkt, ID-Nr und Beschreibung |
| auslesen | ’CommandBarFaceID_List liefert alle FaceIDs mit Bild und ID |
| ’CommandBar_List liest die Excel-internen Bezeichnungen der Menüs, Menüpunkte, deren Typ und ID aus |
| Dim cbb As CommandBarButton, ComBar As CommandBar, cbc As CommandBarControl |
| Sub CommandBarControlID_List() | |
| Dim a, b, c | |
| Application.ScreenUpdating = False | |
| For Each ComBar In Application.CommandBars | |
| If ComBar.Name = "test" Then ComBar.Delete | |
| Next | |
| Set ComBar = Application.CommandBars.Add(Name:="test", |
| Position:=msoBarTop) | |
| b = 0 | |
| c = 1 | |
| For a = 1 To 50000 | |
| On Error Resume Next | |
| Set cbb = ComBar.Controls.Add(Id:=a) | |
| If Err.Number <> 0 Then GoTo weiter | |
| cbb.CopyFace | |
| With Workbooks("FaceIDs").Sheets(1) | |
| .Cells((c Mod 100) + 1, (c \ 100) + b + 1).Formula = a | |
| .Cells((c Mod 100) + 1, (c \ 100) + b + 2).Activate | |
| ActiveSheet.Paste | |
| .Cells((c Mod 100) + 1, (c \ 100) + b + 3).Formula = cbb.Caption |
| End With | |
| If (c + 1) Mod 100 = 0 Then b = b + 3 | |
| c = c + 1 | |
| weiter: | |
| Application.CommandBars("test").FindControl(Id:=a).Delete |
| Err.Clear | |
| Next | |
| End Sub | |
| Sub CommandBarFaceID_List() | |
| Dim a, b | |
| Application.ScreenUpdating = False | |
| For Each ComBar In Application.CommandBars | |
| If ComBar.Name = "test" Then ComBar.Delete | |
| Next | |
| On Error Resume Next | |
| Set ComBar = Application.CommandBars.Add(Name:="test", |
| Position:=msoBarTop) | |
| Set cbb = ComBar.Controls.Add(Id:=1) | |
| b = 0 | |
| For a = 1 To 3518 | |
| With cbb | |
| .FaceId = a | |
| .CopyFace | |
| End With | |
| With ThisWorkbook.Sheets(1) | |
| .Cells((a Mod 100) + 1, (a \ 100) + b + 1).Formula = a | |
| .Cells((a Mod 100) + 1, (a \ 100) + b + 2).Activate | |
| ActiveSheet.Paste | |
| End With | |
| If (a + 1) Mod 100 = 0 Then b = b + 2 | |
| Next | |
| End Sub | |
| Sub CommandBar_List() | |
| Application.ScreenUpdating = False | |
| Dim a, b, c, cbc, d | |
| b = 1 | |
| d = 0 | |
| For Each a In Application.CommandBars | |
| Cells(b + d, 1) = a.Name | |
| Cells(b + d, 2) = "Item-no: " & b | |
| For Each cbc In a.Controls | |
| d = d + 1 | |
| Cells(b + d, 3) = cbc.Caption | |
| Cells(b + d, 4) = Cells(cbc.Type, 10) | |
| Cells(b + d, 5) = "Type: " & cbc.Type | |
| Cells(b + d, 6) = "ID: " & cbc.Id | |
| Next | |
| b = b + 1 | |
| Next | |
| | End Sub | |
| Menüeintrag | Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, _ |
| neuen Befehl | ByVal Target As Excel.Range, Cancel As Boolean) |
| zuordnen | Set chgEinfügen = Application.ShortcutMenus(xlWorksheetCell).MenuItems("Einfügen") |
| With chgEinfügen | |
| .OnAction = "mkrEinfügen" | |
| End With | |
| End Sub | |
| Sub mkrEinfügen() | |
| Selection.PasteSpecial Paste:=xlValues | |
| | End Sub | |
| Quickinfo zuordnen | Sub QuickInfo() | |
| Application.Toolbars("SybolleistenName").ToolbarButtons(Indexzahl).Name = "Infotext" |
| | End Sub | |
| Zahl in Text ändern | Function DollarText(vNumber) As Variant | |
| Dim sDollars As String, sCents As String, iLen As Integer, sTemp As String |
| Dim iPos As Integer, iHundreds As Integer, iTens As Integer, iOnes As Integer |
| Dim bHit As Boolean, vOnes As Variant, vTeens As Variant, vTens As Variant |
| Dim sUnits(2 To 5) As String | |
| If Not IsNumeric(vNumber) Then | |
| Exit Function | |
| End If | |
| sDollars = Format(vNumber, "###0.00") | |
| iLen = Len(sDollars) - 3 | |
| If iLen > 15 Then | |
| DollarText = CVErr(xlErrNum) | |
| Exit Function | |
| End If | |
| sCents = Right$(sDollars, 2) & "/100 Dollars" | |
| If vNumber < 1 Then | |
| DollarText = sCents | |
| Exit Function | |
| End If | |
| sDollars = Left$(sDollars, iLen) | |
| vOnes = Array("", "One", "Two", "Three", | |
| "Four", "Five", "Six", "Seven", "Eight", "Nine") | |
| vTeens = Array("Ten", "Eleven", "Twelve", | |
| "Thirteen", "Fourteen", "Fifteen", "Sixteen", "Seventeen", |
| "Eighteen", "Nineteen") | |
| vTens = Array("", "", "Twenty", "Thirty", | |
| "Forty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety") | |
| sUnits(2) = "Thousand" | |
| sUnits(3) = "Million" | |
| sUnits(4) = "Billion" | |
| sUnits(5) = "Trillion" | |
| sTemp = "" | |
| For iPos = 15 To 3 Step -3 | |
| If iLen >= iPos - 2 Then | |
| bHit = False | |
| If iLen >= iPos Then | |
| iHundreds = Asc(Mid$(sDollars, iLen - iPos + 1, 1)) - 48 |
| If iHundreds > 0 Then | |
| sTemp = sTemp & " " & vOnes(iHundreds) & "Hundred" |
| bHit = True | |
| End If | |
| End If | |
| iTens = 0 | |
| iOnes = 0 | |
| If iLen >= iPos - 1 Then | |
| iTens = Asc(Mid$(sDollars, iLen - iPos + 2, 1)) - 48 |
| End If | |
| If iLen >= iPos - 2 Then | |
| iOnes = Asc(Mid$(sDollars, iLen - iPos + 3, 1)) - 48 |
| End If | |
| If iTens = 1 Then | |
| sTemp = sTemp & " " & vTeens(iOnes) | |
| bHit = True | |
| Else | |
| If iTens >= 2 Then | |
| sTemp = sTemp & " " & vTens(iTens) | |
| bHit = True | |
| End If | |
| If iOnes > 0 Then | |
| If iTens >= 2 Then | |
| sTemp = sTemp & "-" | |
| Else | |
| sTemp = sTemp & " " | |
| End If | |
| sTemp = sTemp & vOnes(iOnes) | |
| bHit = True | |
| End If | |
| End If | |
| If bHit And iPos > 3 Then | |
| sTemp = sTemp & " " & sUnits(iPos \ 3) | |
| End If | |
| End If | |
| Next iPos | |
| DollarText = Trim(sTemp) & " and " & sCents | |
| | End Function 'DollarText | |
| Umlaute ersetzen | Sub UmlauteWandeln() | |
| Dim MyRange As Range | |
| Dim Cell As Range | |
| Application.ScreenUpdating = False | |
| Set MyRange = Selection | |
| For Each Cell In MyRange | |
| Selection.Replace What:="ß", Replacement:="ss", LookAt:=xlPart, MatchCase:=True |
| Selection.Replace What:="ü", Replacement:="ue", LookAt:=xlPart, MatchCase:=True |
| Selection.Replace What:="Ü", Replacement:="Ue", LookAt:=xlPart, MatchCase:=True |
| Selection.Replace What:="ö", Replacement:="oe", LookAt:=xlPart, MatchCase:=True |
| Selection.Replace What:="Ö", Replacement:="Oe", LookAt:=xlPart, MatchCase:=True |
| Selection.Replace What:="ä", Replacement:="ae", LookAt:=xlPart, MatchCase:=True |
| Selection.Replace What:="Ä", Replacement:="Ae", LookAt:=xlPart, MatchCase:=True |
| Next Cell | |
| | End Sub | |
| Groß-/Kleinschreibung | Sub ToggleCase() | |
| tauschen | Dim Upr, Lwr, Ppr | |
| Set OriginalCell = ActiveCell 'Originaladresse speichern |
| Set OriginalSelection = Selection | |
| If IsEmpty(ActiveCell) Then GoTo NoneFound | |
| On Error GoTo Limiting | |
| If OriginalCell = OriginalSelection Then | |
| Selection.Select | |
| GoTo Converting | |
| Else | |
| Resume Next | |
| End If | |
| Limiting: 'Auswahl auf gültige Zellen begrenzen |
| On Error GoTo NoneFound | |
| Selection.SpecialCells(xlCellTypeConstants, 3).Select |
| Converting: | |
| Application.StatusBar = "Ändere Gross- und Kleinschreibung..." 'Statusbar ändern |
| For Each DCell In Selection.Cells | |
| Upr = UCase(DCell) | |
| Lwr = LCase(DCell) | |
| If Upr = DCell.Value Then | |
| DCell.Value = Lwr | |
| Else | |
| DCell.Value = Upr | |
| End If | |
| Next DCell | |
| Application.StatusBar = False 'Statusbar zurücksetzen |
| Exit Sub | |
| NoneFound: | |
| MsgBox "Alle Zellen der aktuelllen Auswahl enthalten Formeln oder sind leer!", vbExclamation, " Fehler aufgetreten" |
| OriginalSelection.Select | |
| OriginalCell.Activate | |
| | End Sub | |
| Minuszeichen | Sub MinusUmstellen() | |
| umstellen | Range("a1").Select | |
| Do Until ActiveCell.Value = "" | |
| altstring = ActiveCell.Value | |
| längealtstring = Len(altstring) | |
| längealtstring = längealtstring - 1 | |
| rechteszeichen = Right(altstring, 1) | |
| If rechteszeichen = "-" Then neuerstring = Left(altstring, längealtstring): neuerstring = "-" + neuerstring |
| ActiveCell.Value = neuerstring | |
| ActiveCell.Offset(1, 0).Range("A1").Select | |
| Loop | |
| End Sub | |
| Sub TrailingNegatives() | |
| For Each Cell In Selection | |
| Cell.Select | |
| altstring = ActiveCell.Value | |
| längealtstring = Len(altstring) | |
| längealtstring2 = längealtstring - 1 | |
| rechteszeichen = Right(altstring, 1) | |
| If rechteszeichen = "-" Then neuerstring = Left(altstring, längealtstring2): _ |
| neuerstring = "-" + neuerstring: ActiveCell.Value = neuerstring |
| Next | |
| | End Sub | |
| Erste leere Zelle | Sub Finde() | |
| in einer Spalte | Columns(MyColumnNumber).SpecialCells(xlCellTypeBlanks).Cells(1) |
| finden | End Sub | |
| Sub Finde() | |
| Cells(Application.WorksheetFunction.CountA(Columns(MyColumnNumber)) + 1, _ |
| MyColumnNumber) | |
| | End Sub | |
| Zellen im Makro | Sub Kopieren() | |
| ohne Zwischen- | Dim aBereich As Range, bBereich As Range | |
| ablage kopieren | Set aBereich = Range("A1:B2") | |
| Set bBereich = Range("F1:G2") | |
| bBereich.Value = aBereich.Value | Werte übertragen |
| bBereich.NumberFormat = aBereich.NumberFormat | Zahlenformate übertragen |
| | End Sub | |
| Zellen zeilenweise | Private Sub Worksheet_Change(ByVal Target As Excel.Range) |
| ausfüllen | If Target.Address = "$A$1" Then | |
| Set actcell = [C1] | |
| Do While actcell <> "" | |
| Set actcell = actcell.Offset(0, 1) | |
| Loop | |
| actcell.Value = Target.Value | |
| End If | |
| | End Sub | |
| Erste leere Zelle | Sub Finde() | |
| finden | Selection.SpecialCells(xlBlanks).Areas(1).Cells(1).Select |
| | End Sub | |
| Fundstellen in | Sub FundstellenSuchen() | |
| Userform auflisten | Dim C As Range, Gefunden(), i% | |
| For Each C In Tabelle1.Range("A1").CurrentRegion | |
| If InStr(C, "Zei") > 0 Then | |
| ReDim Preserve Gefunden(i) | |
| Gefunden(i) = C.Address(False, False) | |
| UserForm1.ListBox1.List = Gefunden | |
| i = i + 1 | |
| End If | |
| Next C | |
| UserForm1.Show | |
| | End Sub | |
| Zeilen mit Summe | Sub HideRows() | |
| Null ausblenden | For Each rngRow In ActiveSheet.UsedRange.Rows | |
| If Application.Sum(rngRow) = 0 Then | |
| rngRow.EntireRow.Hidden = True | |
| End If | |
| Next rngRow | |
| | End Sub | |
| Zeilen mit Summe | Sub DeleteRow() | |
| Null löschen | Dim N As Long | |
| For N = Selection(1, 1).Row + Selection.Rows.Count - 1 To Selection(1, 1).Row Step -1 |
| With Cells(N, 1) | |
| If .Value = 0 And Not .HasFormula Then | |
| .EntireRow.Delete | |
| End If | |
| End With | |
| Next N | |
| | End Sub | |
| Tabellenname | Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Excel.Range) |
| automatisch nach | If Target.Address = Sh.Range("jobNumber").Address Then |
| Zellinhalt benennen | Sh.Name = szRenameSheet(Sh, Target) | |
| End If | |
| End Sub | |
| Private Function szRenameSheet(ByVal Sh As Worksheet, ByVal Target As Excel.Range) As String |
| Dim szName As String | |
| If Not IsNull(Target) Then | |
| szName = CStr(Target.Value) | |
| With Application.WorksheetFunction | |
| szName = .Substitute(szName, ":", "") | |
| szName = .Substitute(szName, "/", "") | |
| szName = .Substitute(szName, "\", "") | |
| szName = .Substitute(szName, "?", "") | |
| szName = .Substitute(szName, "*", "") | |
| szName = .Substitute(szName, "[", "") | |
| szName = .Substitute(szName, "]", "") | |
| End With | |
| szRenameSheet = Left$(szName, 31) | |
| End If | |
| | End Function | |
Neuberechnung
erzwingen | SendKeys "^%{F9}" | |
| Formeln zählen | Sub Count_Formula() | |
| Dim R As Integer | |
| R = 0 | |
| Range(Cells(1, 1), Selection.SpecialCells(xlLastCell)).Select |
| For Each Cell In Selection | |
| If Left(Cell.Formula, 1) = "=" Then | |
| R = R + 1 | |
| End If | |
| Next Cell | |
| Selection.SpecialCells(xlFormulas, 23).Select | |
| MsgBox "Es sind " & R & " Formeln in der Tabelle " & ActiveSheet.Name & "enthalten" |
| End Sub | |
| Sub CountFormSub() | |
| MsgBox ActiveSheet.UsedRange.SpecialCells(xlFormulas).Count |
| End Sub | |
| Function countformulas() As Integer | |
| Dim x As Range, y As Integer | |
| Application.Volatile | |
| For Each x In ActiveSheet.UsedRange | |
| If x.HasFormula Then y = y + 1 | |
| Next x | |
| countformulas = y | |
| | End Function | |
| Seitenzahlen in Zelle | Sub SeitenNr() | |
| Dim Trennzeile As Variant | |
| Dim AlteZeile As Integer | |
| Dim Trennspalte As Variant | |
| Dim AlteSpalte As Integer | |
| Dim V_Seitenanzahl As Integer | |
| Dim H_Seitenanzahl As Integer | |
| Dim V_Seite As Integer | |
| Dim H_Seite As Integer | |
| V_Seitenanzahl = 0 | |
| V_Seite = 0 | |
| AlteZeile = 0 | |
| AlteSpalte = 0 | |
| Do | |
| V_Seitenanzahl = V_Seitenanzahl + 1 | |
| Trennzeile = ExecuteExcel4Macro("INDEX(GET.DOCUMENT(64)," & |
| V_Seitenanzahl & ")") | |
| If IsError(Trennzeile) Then Exit Do | |
| If Trennzeile <= AlteZeile Then Exit Do | |
| AlteZeile = Trennzeile | |
| If Trennzeile >= ActiveCell.Row And V_Seite = 0 Then | |
| V_Seite = V_Seitenanzahl | |
| End If | |
| Loop | |
| V_Seitenanzahl = V_Seitenanzahl - 1 | |
| H_Seitenanzahl = 0 | |
| H_Seite = 0 | |
| Do | |
| H_Seitenanzahl = H_Seitenanzahl + 1 | |
| Trennspalte = ExecuteExcel4Macro("INDEX(GET.DOCUMENT(65)," _ |
| & H_Seitenanzahl & ")") | |
| If IsError(Trennspalte) Then Exit Do | |
| If Trennspalte <= AlteSpalte Then Exit Do | |
| AlteSpalte = Trennspalte | |
| If Trennspalte >= ActiveCell.Column And H_Seite = 0 Then |
| H_Seite = H_Seitenanzahl | |
| End If | |
| Loop | |
| H_Seitenanzahl = H_Seitenanzahl - 1 | |
| If ActiveSheet.PageSetup.Order = xlOverThenDown Then |
| ActiveCell.Formula = "Seite " & (V_Seite - 1) * H_Seitenanzahl + |
| H_Seite & " von " & H_Seitenanzahl * V_Seitenanzahl |
| Else | |
| ActiveCell.Formula = "Seite " & (H_Seite - 1) * V_Seitenanzahl + |
| V_Seite & " von " & H_Seitenanzahl * V_Seitenanzahl |
| End If | |
| | End Sub | |
| Arbeitsmappen | Sub CompareWorkbooks() | |
| vergleichen | Dim iWB As Integer, iWS As Integer | |
| Dim rngObj As Range | |
| If Workbooks(1).Worksheets.Count <> Workbooks(2).Worksheets.Count Then |
| MsgBox "Number of worksheets differs" | |
| Exit Sub | |
| End If | |
| For iWS = 1 To Workbooks(1).Worksheets.Count |
| If Workbooks(1).Worksheets(iWS).UsedRange.Cells.Count <> _ |
| Workbooks(2).Worksheets(iWS).UsedRange.Cells.Count Then |
| MsgBox "Number of used cells in sheet " & iWS & "differs" |
| Exit Sub | |
| End If | |
| For Each rngObj In Workbooks(1).Worksheets(iWS).UsedRange |
| If rngObj.Value <> Workbooks(2).Worksheets(iWS).Range(rngObj.Address).Value |
| Then | |
| For iWB = 1 To 2 | |
| Workbooks(iWB).Worksheets(iWS).Activate | |
| ActiveSheet.Range(rngObj.Address).Activate | |
| Next | |
| MsgBox "Difference detected at sheet " & iWS & " at cell " & rngObj.Address(False, False) |
| Exit For | |
| End If | |
| Next | |
| Next | |
| | End Sub | |
| Excel - Fenster | Sub InTheMiddle() | |
| positionieren | Dim dWidth As Double, dHeight As Double | |
| With Application | |
| .WindowState = xlMaximized | |
| dWidth = .Width | |
| dHeight = .Height | |
| .WindowState = xlNormal | |
| .Top = dHeight / 4 | |
| .Height = dHeight / 2 | |
| .Left = dWidth / 4 | |
| .Width = dWidth / 2 | |
| End With | |
| | End Sub | |
| Fußzeilen bei | Sub Datum_in_Fusszeile() | |
| doppelseitigem | Dim SeitenNummer%, X%, Zaehler As Boolean | |
| Ausdruck | Zaehler = True | |
| X = ExecuteExcel4Macro("get.document(50)") | |
| For SeitenNummer = 1 To X | |
| If Zaehler = True Then | |
| With ActiveSheet.PageSetup | |
| .RightFooter = "&D" | |
| .LeftFooter = "" | |
| End With | |
| End If | |
| If Zaehler = False Then | |
| With ActiveSheet.PageSetup | |
| .RightFooter = "" | |
| .LeftFooter = "&D" | |
| End With | |
| End If | |
| ActiveWindow.SelectedSheets.PrintOut From:=SeitenNummer, To:=SeitenNummer, Copies:=1 |
| Zaehler = Not Zaehler | |
| Next SeitenNummer | |
| | End Sub | |
| Datensätze | Sub DatensaetzeLoeschen() | Diese Prozedur kann man wie folgt einsetzen: |
| automatisch | Antwort = MsgBox("Alle sichtbaren Zeilen löschen?", _ | 1. Filter definieren, so dass in der Liste nur noch |
| löschen | vbYesNo, "Zeilen löschen") | Einträge angezeigt werden, die man löschen will. |
| If Antwort = vbNo Then GoTo Ende | |
| Application.ScreenUpdating = False | 2. Auf eine beliebige Zelle in der Liste klicken. |
| ErsteZeile = ActiveCell.CurrentRegion.Row + 1 | 3. Das Makro starten. |
| ErsteSpalte = ActiveCell.CurrentRegion.Column | 4. Nachdem man die Abfrage mit JA bestätigt hat |
| LetzteZeile = ErsteZeile + _ | werden die gefundenen Listenzeilen gelöscht. |
| ActiveCell.CurrentRegion.Rows.Count - 2 | 5. Mit DATEN-FILTER-ALLE ANZEIGEN den Rest |
| LetzteSpalte = ErsteSpalte + _ | der Liste wieder einblenden. |
| ActiveCell.CurrentRegion.Columns.Count - 1 | Funktionsweise des Makros: Nachdem die Abfrage |
| Set SichtbarerBereich = Range(Cells(ErsteZeile, _ | mit JA beantwortet wurde, ermittelt die Prozedur |
| ErsteSpalte), Cells(LetzteZeile, _ | die erste / letzte Zeile, sowie die erste / letzte Spalte |
| LetzteSpalte)).SpecialCells(xlVisible) | des Datenbereiches. Anschließend werden alle |
| AnzahlBereiche = SichtbarerBereich.Areas.Count | sichtbaren Zellen des Datenbereichs markiert. |
| For Zaehler = 1 To AnzahlBereiche | Da es sich um ein Filterergebnis handelt, werden |
| Range(SichtbarerBereich.Areas(1).Address). _ | zwischen den sichtbaren Zeilen die nicht passenden |
| Delete Shift:=xlUp | Einträge ausgeblendet; die Markierung besteht |
| Next | aus mehreren Bereichen. Die Anzahl der Bereiche |
| Application.ScreenUpdating = True | wird mit "Areas.Count" ermittelt und eine For- |
| Ende: | Next-Schleife löscht jeden Bereich mit "Delete". |
| | End Sub | |
| Bedingte Formatierung | Private Sub Worksheet_Change(ByVal Target As Excel.Range) |
| mit mehr als | Select Case Target.Value | |
| drei Bedingungen | Case 1 | |
| Target.Interior.ColorIndex = 1 'Schwarz | |
| Case 2 | |
| Target.Interior.ColorIndex = 2 'Weiss | |
| Case 3 | |
| Target.Interior.ColorIndex = 3 'Rot | |
| Case 4 | |
| Target.Interior.ColorIndex = 4 'Grün | |
| Case 5 | |
| Target.Interior.ColorIndex = 5 'Blau | |
| Case 6 | |
| Target.Interior.ColorIndex = 6 'Gelb | |
| Case Else | |
| Target.Interior.ColorIndex = xlColorIndexNone | |
| End Select | |
| | End Sub | |
| Die drei höchsten | Man möchte die drei größten Werte aus einem Bereich von 100 Zellen |
| Werte summieren | summieren. Das Problem dabei ist, dass die Werte nicht sortiert sind, so |
| dass der Einsatz einer einfachen Summenformel ausscheidet. |
| Die Spitzenwerte eines Tabellenbereichs kann man mit der Funktion |
| KGROESSTE ermitteln. Die Funktion erwartet als ersten Parameter die |
| Adresse des zu durchsuchenden Bereichs und als zweiten Parameter |
| eine Zahl, die angibt, welchen Wert man genau sucht. |
| Wenn sich die Werte zum Beispiel im Bereich A1:A100 befinden, |
| liefert folgende Formel den höchsten Wert: | =KGROESSTE(A1:A100;1) |
| Die Summe aus dem "höchsten", dem "zweithöchsten" und dem |
| dritthöchsten Wert erhält man mit folgender Formel: | =KGROESSTE(A1:A100;1)+KGROESSTE( |
| | A1:A100;2)+KGROESSTE(A1:A100;3) |
| Verkürzen lässt sich der Ausdruck mit einer Arrayformel: | =SUMME(KGROESSTE(A1:A100;{1;2;3})) |
| Zur Eingabe einer Arrayformel schließt man den Ausdruck mit |
| Strg+Umschalt+Return ab, so dass Excel die Formel automatisch |
| mit geschweiften Klammern umgibt. |
| Obwohl diese Schreibweise kompakter ist als die zuvor genannte |
| mit dem +-Operator, wird die Eingabe mühseliger, je mehr Spitzenwerte |
| summiert werden sollen. Wenn man etwa die fünf höchsten Werte des |
| Bereichs addieren will, müßte man {1;2;3;4;5}" als Parameterarray |
| eingeben. | |
| Flexibler ist folgende Formel (hier für fünf Spitzenwerte): | =SUMME(KGROESSTE(A1:A100;ZEILE( |
| Auch diese Formel muss man per Strg+Umschalt+Return | INDIREKT("1:5")))) |
| als Arrayformel eingeben. Wenn man aber eine andere Summe - z.B. aus den zehn |
| höchsten Werten - benötigt, muss man den zweiten Wert der INDIREKT- |
| | Funktion anpassen, indem man statt "5" den Wert "10" einträgt. |
| Arbeitslohn mit | An diesem Beispiel erkennt man, dass das Rechnen mit | =ZEITWERT("18:00")-ZEITWERT("12:00") |
| Arbeitszeit ermitteln | Uhrzeiten nur bei ganz simplen Additionen und Subtraktionen wirklich einfach ist. |
| Um Arbeitslohn auf Grundlage der berechneten Zeit zu ermitteln, ist es |
| notwendig, Uhrzeiten in eine Dezimalzahl zu verwandeln: | =ZEITWERT("6:00")*24 |
| Das Ergebnis ist in diesem Fall "6" und diese Zahl kann man dann mit |
| einem Stundensatz multiplizieren. |
| | So wandelt man eine Dezimalzahl in eine Uhrzeit um: | die Zahl durch 24 dividieren. |
| Alle Symbolleisten | Sub SymbolleistenReset() | |
| zurücksetzen | Dim Leiste As CommandBar | |
| For Each Leiste In CommandBars | |
| If Leiste.Type = msoBarTypeNormal Then | |
| If Leiste.BuiltIn Then Leiste.Reset | |
| End If | |
| Next Leiste | |
| | End Sub | |
| | |
zurück