|
VBA ist eine Scriptsprache (die Programmiersprache Visual Basic for Applications), mit der unzählig viele Programme (Scripte) für Microsoft Office Anwendungen erstellt werden können.
Für die Anwendung Excel bieten wir euch nachfolgend eine nützliche VBA Makro Sammlung. Stets wiederkehrende Aufgaben lassen sich so automatisieren, zum Beispiel das Sortieren von vielen Arbeitsblättern, das Abspeichern von Dateien unter einem bestimmten Namen mit Tagesdatum, oder das Erzeugen von einheitlichen Fußzeilen.
Einige Makro-Beispiele zum Thema "Drucken mit Excel" findet ihr am Ende dieser Dokumentation.
Application = Anwendung (z. B. Excel, Word, Outlook)
Workbook = Excel Arbeitsmappe
Worksheets = Excel Arbeitsblätter
Sheets("Tabelle1").Select = selektiertes Excel Arbeitsblatt
Objekte:
ActiveWorkbook = aktive Excel Arbeitsmappe
ActiveSheet = aktives Excel Arbeitsblatt
ActiveCell = aktive Zelle auf einem Excel Arbeitsblatt
Range oder Cells = einzelne Zelle bzw. ein bestimmter Bereich auf einem Excel Arbeitsblatt
Sub Text1()
Range("B3:F5").Value = "Test" 'Zellen wird der Wert "TEST"zugewiesen
End Sub
Sub Text2()
Range("b2:f15").Activate 'Activate markiert den Zellbereich
End Sub
Sub Text3()
Dim a As String 'A und B werden als Zeichenkette deklariert
Dim B As String
a = 5
B = 4
Range("b6") = a + B 'Zelle B6 wird die Zeichenkette (54) zugewiesen
End Sub
Sub Text4()
Dim x As Integer 'x und y werden als Ganzzahlen deklariert
Dim y As Integer
x = 17
y = 8
Range("c12") = x * y 'Es wird das Produkt aus 17 mal 8 zugewiesen
End Sub
Durch Voranstellen eines Hochkommas ' wird Code als Kommentar verstanden und grün angelegt.
Will man nicht nur eine Zeile auskommentieren, sondern einen ganzen Block, bietet Excel im VBA-Editor im Menü Ansicht unter Symbolleisten die Option "Bearbeiten". Dort 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 (des ausgewählten Bereiches) zurücknehmen.
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
Sub ABlattSortieren()
'Durch Änderung des < Zeichens in ein > Zeichen kann eine absteigende Sortierung erreicht werden
Dim i%, j%
For i = 1 To Sheets.Count
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
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
Sub DateiUnterTagesdatumAbspeichern()
Dim Dateiname As String, Ppfad As String
Dateiname = Format(Now(), "ddmmyyyy")
Ppfad = "D:\MyFiles\"
ActiveWorkbook.SaveAs (Ppfad & Dateiname)
'Andere Schreibweise:
'ActiveWorkbook.SaveAs filename:="C:\myfile.xls", FileFormat:=xlNormal
End Sub
Sub DateiUnterTagesdatumAbspeichern()
Dim Dateiname As String
Dateiname = Format(Now(), "yyyy-mm-dd")
Application.Dialogs(xlDialogSaveAs).Show (Dateiname)
End Sub
Sub NumerischerWertInZelle()
If Not Application.IsNumber(ActiveCell) Then
MsgBox "Zelle enthält kein numerisches Zeichen"
End If
End Sub
Function ArbeitsmappeOffen(AMappe As String) As Boolean
On Error Resume Next
MappeText = Workbooks(AMappe).Name
'Fehler: ArbeitsmappeOffen = False
On Error GoTo Fehler
Workbooks.Open AMappe
OpenBook = True
Exit Function
End Function
Sub NameUndPosEinerSchaltfläche()
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
Sub SchaltflächeDeaktivieren()
'Auf dem ersten Arbeitsblatt wird die erste Schaltfläche deaktiviert
Sheets("Tabelle1").Buttons(1).Enabled = False
End Sub
Sub ZwischenablageLöschen()
Application.CutCopyMode = False
End Sub
Sub AnzahlVerwendeteZeilen()
i = ActiveSheet.UsedRange.Rows.Count
MsgBox i
End Sub
Sub MehrereZeilenMarkieren()
Range("1:1,3:3,5:5,9:9,11:11").Select
End Sub
Sub ExcelBeenden()
Application.Quit
End Sub
Vor dem Speichern wird das "MakroX" aufgerufen, welches den aktuellen Pfad einer Datei in die 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".
Sub Auto_Open()
ActiveWorkbook.OnSave = "MacroX"
End Sub
Sub MacroX()
ActiveSheet.PageSetup.LeftFooter = "&8" + ActiveWorkbook.Path
End Sub
'Hinweis: Auto_Open funktionierte nicht immer bei uns, also probierten wir es so:
Sub ActiveWorkbook_BeforeSave()
ActiveSheet.PageSetup.LeftFooter = "&8" + ActiveWorkbook.Path
End Sub
Sub cmdButton1_Click()
'Bedingung: Der Text in der Textbox muss mit Umschalt und Enter umgebrochen werden
'Der Textbox muss zuvor "MultiLine = True" sowie "WordWrap = True" zugewiesen werden
Dim i%, Zeile$
Zeile = TextBox1.Text
While InStr(Zeile, Chr(10)) > 0
i = i + 1
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
Sub AlleAusgeblendetenZeilenAnzeigen()
Dim r
For Each r In ActiveSheet.UsedRange.Rows
If r.Hidden = True Then r.Hidden = False
Next r
End Sub
Sub InternetExplorer_Oeffnen()
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
Sub cmdUebertragen_Click()
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
Sub Intervall()
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
End Sub
Sub Wochenenden_Farben()
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
Sub FussZeileErzeugen()
With ActiveSheet.PageSetup
'Linksbündig Dateiname
.LeftFooter = "&""Arial,Fett""&12&A"
'Rechtsbündig Seitenzahlen
.RightFooter = "Seite&Pvon&N"
'Dateinamen inklusive Pfadangabe
.CenterFooter = ActiveSheet.Parent.FullName
End With
'Name der Arbeitsmappe und Seitenzahl
Worksheets("Sheet1").PageSetup.CenterFooter = "&F Seite &P"
End Sub
Sub ProgrammAusExcelAufrufen()
Status = Shell("notepad.exe"; 1)
'Weitere Beispiele: calc.exe = Taschenrechner. mspaint.exe = Zeichenprogramm. sol.exe = Solitär
End Sub
Sub ExcelDateienZaehlen()
With Application.FileSearch
.NewSearch
.LookIn = "C:\Eigene Dateien"
.FileName = "*.xls"
.Execute
MsgBox .FoundFiles.Count
End With
End Sub
Function milHours(dteTime As Date)
'Bruchteile von Sekunden werden bei einer Zeitformatierung dezimal dargestellt
Dim i%
i = Second(dteTime) 'Zellformatierung beachten: hh:mm:000 ergibt z. B. 12:05:456
i = i / 60 * 1000
'Dieses Modul mit folgendem Syntax auf dem Worksheet aktivieren: =Projektname.xls!milHours(A1)
milHours = Format(Hour(dteTime), "00") & ":" & Format(Minute(dteTime), "00") & ":" & i
End Function
Sub PcPiep()
AnzBeeps = InputBox("Wie oft soll gepiepst werden?")
For Count = 1 To AnzBeeps
Beep
'Zwischen jedem Pieps liegt eine Pause von einer Sekunde
Application.Wait Now() + TimeValue("00:00:01")
Next Count
End Sub
Sub Auto_Open()
On Error Resume Next
Application.Dialogs(xlDialogOpen).Show
'Bei Angabe des Dateinamens springt der Dialog gleich ins richtige Verzeichnis:
'Application.Dialogs(xlDialogOpen).Show "Muster.xls"
End Sub
Sub AnsichtGanzerBildschirm()
Application.DisplayFullScreen = True
End Sub
Sub AlleNamenInMappeLoeschen()
Dim definedName As Object
For Each definedName In ActiveWorkbook.Names
definedName.Delete 'Löscht benutzerdefinierte Namen in allen Worksheets
Next
End Sub
Function DateiName()
'Verwendung: In Zelle A1 eines Tabellenblattes z. B. den Befehl: =DateiName() eingeben
DateiName = ActiveWorkbook.Name
End Function
Sub ArbeitsblattUmbenennen()
ActiveSheet.Name="Neuer Name"
End Sub
Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
MsgBox Prompt:="Der KeyAscii lautet " & KeyAscii
End Sub
Sub Worksheet_Activate()
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
Sub TextAusTextfeld()
Dim t%, z%
With ActiveSheet.TextBoxes(1)
For z = 1 To .Characters.Count Step 255
'Das erste Textfeld des aktiven Tabellenblattes wird ausgelesen
t = t & .Characters(z, 255).Text
Next z
End With
'Der Operator & verkettet die Anzahl der Zeichen und den Inhalt des Textfeldes
MsgBox Len(t) & " " & t
End Sub
Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim i%
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
Sub HyperlinkMitEmailEinfügen()
Range("A1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="mail:testme@a.com"
End Sub
Sub HyperlinkAktivieren()
Range("A1").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
End Sub
Sub Auto_Open()
Application.OnKey "^w", "WerteEinfügen"
End Sub
Sub WerteEinfügen()
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= False, Transpose:=False
End Sub
Sub EingabeÜberInputbox()
Dim wert01$
wert01 = InputBox("Wert eingeben", "Bitte geben Sie einen Wert ein")
Range("a1").Value = wert01
End Sub
Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Sheets(1).Activate
End Sub
Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then Cancel = True
'2. Möglichkeit: If CloseMode <> 1 Then Cancel = 1
End Sub
Sub Grafiken_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
Sub Hyperlinks_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
Sub Hyperlinks_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
Sub ProgrammXYZ()
If Err > 0 Then
Err.Clear
'hier weitere Befehle einfügen
End If
On Error Goto 0
End Sub
Sub ProgramXYZ()
Screen.MousePointer = vbHourglass
Application.Cursor = xlWait 'schaltet die Sanduhr ein
'hier weitere Befehle einfügen
Screen.MousePointer = vbDefault 'schaltet den Mauszeiger wieder ein
Application.Cursor = xlNorthwestArrow 'oder: xlDefault
End Sub
Sub Worksheet_Calculate()
'Verwendung: Dieses Makro in die betreffende Tabelle einbinden
'Die Spaltenbreite wird immer nach Zell-Eingabe automatisch angepasst
Columns("A:G").AutoFit
End Sub
Sub Workbook_SheetCalculate(ByVal Sh As Object)
'Verwendung: Dieses Makro in das Workbook einbinden
'Die Spaltenbreite wird nur für das aktuell bearbeitete Worksheet nach Zell-Eingabe automatisch angepasst
Columns("B:E").AutoFit
End Sub
Sub Neues_Blatt_Anlegen()
Dim wks As Worksheet, nme As Name, intNme%, strNme$
'Bereits vergebene Namen dürfen sich auch dann nicht wiederholen, wenn die Blätter inzwischen gelöscht wurden
For Each nme In ThisWorkbook.Names
strNme = Right(nme.Name, 3)
If Len(strNme) = 3 And IsNumeric(strNme) Then
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
Sub Hide_All_Rows()
'Auf dem Tabellenblatt kann man über die Registerkarte "Entwicklertools" einen Button einbinden, mit dem man das Makro ständig ein- oder ausschalten kann. Startzelle = A1. Die Startzeile kann auch z. B. mit 5 beginnen
Dim zeile%, zelle As Range
zeile = 1
Set zelle = ActiveSheet.Cells(zeile, 1)
'Makro ausführen, bis HEUTE in Spalte 1 gefunden wird
Do Until zelle(zeile, 1) = Date
If zelle(zeile, 1).Value <= Date And Rows(zeile).EntireRow.Hidden = False Then
'Andere Möglichkeit: ... .Value < DateSerial(1999, 10, 30) ...
Rows(zeile).EntireRow.Hidden = True 'Alle Zeilen verstecken, bis HEUTE gefunden wird
Else
Rows(zeile).EntireRow.Hidden = False 'Alle Zeilen wieder sichtbar machen
End If
zeile = zeile + 1 'Zeilenzähler
Loop
'Am Schluss wird jene Zelle in der 2. Spalte selektiert, die in der HEUTE-Zeile steht
zelle(zeile, 2).Select
End Sub
Sub Lies_Datei()
Workbooks.Open FileName:=[A1]
End Sub
Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Row = 2 Then Cells(Target.Row - 1, Target.Column) = Date
End Sub
Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 2 Then Cells(Target.Row, Target.Column - 1) = Now
End Sub
Sub einfuegen()
Sheets(1).Cells(1, 2) = CDbl(InputBox.Text)
'Hinweis: Diese Lösung bringt falsche Nachkommastellen: Format(InputBox.Text, "##0.0000")
End Sub
Sub Blatt_kopieren()
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 neue Datei entsteht
Set wkbZiel = ActiveWorkbook
Set wksZiel = ActiveSheet
wksZiel.Cells(1, 1) = "Hallo"
wkbZiel.Close savechanges:=True
'Am Ende nicht vergessen, den Speicher freizugeben
Set wkbZiel = Nothing
Set wksZiel = Nothing
Set wkbQuell = Nothing
Set wksQuell = Nothing
End Sub
Sub cmdComment_Click()
'Auf dem Tabellenblatt kann man über die Registerkarte "Entwicklertools" einen Button einbinden, mit dem man das Makro starten kann
Dim x As Comment
'Schleife im Worksheet
For Each x In ActiveSheet.Comments
With x.Shape.TextFrame.Characters.Font
.Name = "Arial" 'Schriftart
.Size = 9 'Schriftgröße
.Bold = False 'Schriftformatierung
End With
With x.Shape 'Größe der Kommentar-Fenster einheitlich formatieren
.Width = 250
.Height = 250
End With
Next x
Range("a1").Select
End Sub
Sub Kommentar_ohne_UserName()
'Fehler abfangen, falls bereits ein Kommentar existiert
On Error Resume Next
Dim x As Comment
ActiveCell.Select
'Kommentar eingabebereit machen (danach reinklicken und schreiben)
Set x = ActiveCell.AddComment
x.Visible = True
x.Text "" 'UserName löschen
With x.Shape 'Größe der Kommentar-Fenster einheitlich formatieren
.Width = 150
.Height = 150
End With
With x.Shape.TextFrame.Characters.Font
.Name = "Arial" 'Schriftart
.Size = 9 'Schriftgröße
.Bold = False 'Schriftformatierung
End With
'AutoSize lohnt sich nur bei kleinen Kommentaren:
'x.Shape.TextFrame.AutoSize = True
End Sub
Sub DM_Euro()
Const curs As Double = 1.2468 'Konstante für Euro-Kurs
Dim rng As Range
'Nur der benutzte Zellenbereich wird verarbeitet
For Each rng In ActiveSheet.UsedRange.Cells
'Wenn Inhalt numerisch ist UND die Zelle nicht leer ist UND die Zelle keine Formel enthält, dann berechne den Wert neu
If IsNumeric(rng.Value) = True And Not rng.Value = Empty And Not rng.HasFormula Then
rng.Value = Application.Round(rng.Value / curs, 2)
End If
Next rng
End Sub
Private Sub Worksheet_Change(ByVal Ziel As Range)
'Bei jeder Änderung des Worksheet-Inhalts wird geprüft
On Error GoTo 10
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 zu machen
Ziel.Clear 'Alter Wert wird gelöscht
End If
End If
10:
End Sub
Sub AddTicks()
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
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Datum wird vor Speichern in die Zelle A1 geschrieben
Range("A1").Value = Date & " " & Time
End Sub
Sub pagecount()
Dim page_count As Integer
page_count = (ActiveSheet.HPageBreaks.Count + 1) * (ActiveSheet.VPageBreaks.Count + 1)
MsgBox page_count & " Seiten"
End Sub
Sub showform()
'Ein Modul startet das Formular (VBA kennt keinen FormLoad-Befehl)
'vbModeless bewirkt, dass gleichzeitig mit Userform und Worksheet gearbeitet werden kann
UserForm1.Show vbModeless
End Sub
'An die Function wird der Pfad und der Dateiname an "fname" übergeben
(Beispiel: "C:\Windows\dateiname.xls")
Private Function FileExists(fname) As Boolean
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True Else FileExists = False
End Function
Private Function FileNameOnly(pname) As String
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
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
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
Private Function SheetExists(sname) As Boolean
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then SheetExists = True Else SheetExists = False
End Function
Private Function WorkbookIsOpen(wbname) As Boolean
Dim x As Workbook
On Error Resume Next
Set x = Workbooks(wbname)
If Err = 0 Then WorkbookIsOpen = True Else WorkbookIsOpen = False
End Function
Sub PruefenLoeschen()
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
Sub Markierte_Worksheets_Ausblenden()
On Error GoTo ende
ActiveWindow.SelectedSheets.Visible = False
ende:
Exit Sub
End Sub
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
Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim testcell As Range, y#
y = 0
'Prüfung vor Verarbeitung sinnvoll, wenn die weitere Verarbeitung nur eine bestimmte Zelle betrifft
For Each testcell In Selection
y = y + 1
'Falls man versehenlich das ganze Sheet markiert, kann (ohne diese Prüfung) Excel abstürzen
If y > 1 Then Exit Sub
Next testcell
If Not Application.Intersect(Target, Range("B:B")) Is Nothing Then
'...weitere Befehle ausführen
End If
End Sub
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Sub LoopEscape()
Do
DoEvents
If (GetAsyncKeyState(&H1B)) <> 0 Then Exit Do
Loop Until 1 = 2
End Sub
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_bestimmtem_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
Sub Zaehlen()
Dim iRow%, iCol%, iRowL%, iColL%, iCounter%
iRowL = Cells(Rows.Count, 1).End(xlUp).Row
For iRow = 1 To iRowL 'sichtbare Zeilen zählen
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 'sichtbare Spalten zählen
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
Sub Drucke_alles()
Dim datei As String
datei = Dir("E:\MeineDateien\*.xls") 'Pfad und Dateiendung
Application.EnableEvents = False 'Fehlermeldungen unterdrücken
While datei <> ""
Workbooks.Open ("E:\MeineDateien\" & datei) 'Eine Datei nach der anderen öffnen
Workbooks(datei).PrintOut 'Drucke alle Sheets
Workbooks(datei).Close savechanges:=False 'Datei schließen
datei = Dir() 'Nächste Datei ermitteln
Wend
Application.EnableEvents = True
End Sub
Sub Drucke_Seite_200_bis_1()
Dim i%, seite%
seite = ExecuteExcel4Macro("Get.Document(50)")
For i = seite To 1 Step -1
ActiveSheet.PrintOut From:=i, To:=i
Next
End Sub
Sub Drucke_Blatt_z_bis_a()
Dim i%
For i = Sheets.Count To 1 Step -1
Sheets(i).PrintOut
Next i
End Sub
Sub Drucke_alles_rueckwaerts()
Dim i%, x%, seite%
seite = ExecuteExcel4Macro("Get.Document(50)")
For i = Sheets.Count To 1 Step -1
For x = seite To 1 Step -1
Sheets(i).PrintOut From:=x, To:=x
Next x
Next i
End Sub
© VBA Makro Programmierung mit Excel wurde dokumentiert von Winfried Brumma (Pressenet), 2020.
Archive:
Jahrgänge:
2022 |
2021 |
2020 |
2019 |
2018 |
2017 |
2016 |
2015 |
2014 |
2013 |
2012 |
2011 |
2010 |
2009
Themen:
Autor werden |
Buch-Rezensionen |
Ratgeber |
Sagen & Legenden |
Fantasy Mythologie |
IT & Technik |
Krimi Thriller |
Fachartikel & Essays |
Jugend- & Kinderbücher |
Bedeutung der Tarotkarten |
Bedeutung der Krafttiere
Noch mehr Bücher lesen (Werbung):
Fantasy & Science Fiction
| Krimis & Thriller
| Ratgeber
| Reise & Abenteuer
Sie schreiben anspruchsvolle Romane und Erzählungen? Wir suchen neue Autorinnen und Autoren. Melden Sie sich!
Wenn Sie die Informationen auf diesen Seiten interessant fanden, freuen wir uns über einen Förderbeitrag. Empfehlen Sie uns auch gerne in Ihren Netzwerken. Herzlichen Dank!
Sitemap Impressum Datenschutz RSS Feed