1 | Option Explicit | Variablen müssen immer definiert werden. Über Subs im jeweiligen Modul schreiben | | Excel VBA [allgemein] | | - |
2 | Option Base | Laufzahlen fangen bei 1 (statt 0) an | | Excel VBA [allgemein] | | - |
7 | Ausgabe: MsgBox | Meldefenster mit Nachricht ausgeben | | Excel VBA [allgemein] | Sub Nachricht()
MsgBox ("Hello World!")
End Sub
| - |
8 | Ausgabe: debug.print | Gibt Nachricht ins Direktfenster aus | | Excel VBA [allgemein] | Sub Nachricht()
Debug.Print ("Hello World!")
'im Direktfenster eingeben: ?
'?range("A1").formula -> zeigt Formel in Englisch an
End Sub
| - |
9 | Ordner wechseln | Wechselt Arbeitsverzeichnis | | Excel VBA [allgemein] | Sub OrdnerWechseln()
MsgBox CurDir 'Ausgabe aktuelles Verz
ChDir (ThisWorkbook.Path) 'wechselt Verzeichnis dorthin wo aktuelle Datei liegt
MsgBox CurDir 'Ausgabe aktuelles Verz
End Sub
| - |
10 | Ordner erstellen | Erstellt Ordner | | Excel VBA [allgemein] | Sub OrdnerErstellen()
Dim sep As String
sep = Application.PathSeparator
MkDir (ThisWorkbook.Path & sep & "test") 'neues Verz
End Sub
| - |
11 | Pfadtrenner | je nach Betriebssystem gibt es unterschiedliche Dateistrukturen. Hiermit erhält man das Trennzeichen zur Pfadangabe im jeweiligen OS | | Excel VBA [allgemein] | Sub PfadTrenner()
Dim sep As String
sep = Application.PathSeparator 'Pfadtrenner: für Windows \ für Mac :
MsgBox sep
End Sub
| - |
12 | Ordner löschen | löscht Ordner | | Excel VBA [allgemein] | Sub OrdnerLoschen()
Dim sep As String
sep = Application.PathSeparator
RmDir (ThisWorkbook.Path & sep & "test") 'löscht Verz
End Sub
| - |
13 | Datei umbenennen | Benennt Datei um; Der Pfad muss entsprechend angepasst werden | | Excel VBA [allgemein] | Sub DateiUmbenennen()
Name Pfad & "Name.xlsm" As Pfad & "Name2" & ".xlsm"
End Sub
| - |
14 | Datei löschen | löscht Datei; Der Pfad muss entsprechend angepasst werden | | Excel VBA [allgemein] | Sub DateiLoschen()
Kill ("Pfad" & "Name")
End Sub
| - |
15 | Datei kopieren | Kopiert Datei vom Ordner1 nach Ordner2 | | Excel VBA [allgemein] | Sub Kopieren()
Call Copy("Ordner1", "Ordner2", "Datie")
End Sub
Private Sub Copy(ByVal SrcPath As String, _
ByVal DstPath As String, _
ByVal FileName As String)
Dim src As Variant, dst As Variant
src = SrcPath & FileName ' Namen der Quelldatei festlegen.
dst = DstPath & FileName ' Namen der Zieldatei festlegen.
FileCopy src, dst ' Quell- in Zieldatei kopieren.
End Sub
| - |
17 | Sonderzeichen | listet verfügbare Sonderzeichen auf | | Excel VBA [allgemein] | Sub Zeichen()
'Sonderzeichen auflisten
Dim Zei As Long
Application.ScreenUpdating = False
For Zei = 33 To 65535
ActiveSheet.Cells(Zei - 32, 2).Value = ChrW(Zei)
ActiveSheet.Cells(Zei - 32, 3).Value = Zei
Next Zei
Application.ScreenUpdating = True
End Sub
| - |
18 | letzte Zeile | findet die letzte Zeile im aktiven Tabellenblatt | | Excel VBA [häufig] | Sub letzteZeile()
Dim lar As Long
'1.
lar = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
'entspricht allerletzte zeile (A1048576) und dann zurück zur letzten benutzten
'2
lar = ActiveSheet.usedrange.Rows.count
'UsedRange= Bereich in dem der Benutzer Daten oder gearbeitet hat
End Sub
| - |
19 | letzte Spalte | findet die letzte Spalte im aktiven Tabellenblatt | | Excel VBA [allgemein] | Sub letzteSpalte()
'Spalte
Dim laC As Long
'1.
laC = ActiveSheet.Cells(1, Columns.count).End(xlToLeft).Column
'2
laC = ActiveSheet.usedrange.Columns.count
'UsedRange= Bereich in dem der Benutzer Daten oder gearbeitet hat
End Sub
| - |
20 | Variablen definieren | Zeigt ein paar Regeln zur Definition von Variablen | | Excel VBA [allgemein] | Sub VariablenDefinieren()
'VBA unterscheidet nicht zwischen Groß-, Kleinschreibung
'für Modul gültig: Deklaration vor 1. Sub -> (Deklarationen)
'für Prozedur gültig: Deklaration im jew. Sub
'Option Explicit 'man muss alle Variablen definieren
'Option Base 1 'definiert den unteren Index zB für Arrays: dim meinArray (100) as integer -> (1 to 100)
'—————————————————————————
'Dim, Private: Variable definieren: gleich; Dim wird eher in Prozedur benutzt, während Private für Modulgültigkeit benutzt wird
'Static: nur Prozedur; Wert bleibt erhalten auch wenn Prozedur beendet ist (solange Arbeitsmappe offen)
'Public: Variable in allen Modulen und Prozeduren gültig
'Const: Konstante; zb Public Const Pfad as string = "Mappe1.xls"
'————————————————————————————
'dim a as
'String: Text
'Range: Bereich, erforder "Set"
'Byte: Ganzzahlen vo 0 bis 255
'Integer: Ganzzahlen von -32.768 bis 32,767
'Long: Ganzzahlen numerische Werte von -2 Mrd. bis 2 Mrd
'Single: Fließkommazahlen -3,4E38 bis -1,4E-45 für neg. 1,4E-45 bis 3,4E38 für pos. Werte
'Double: Fließkommazahlen doppelte Genauigkeit; +/- 1E308#
'Currency: +/- 900 Mrd., 4 Nachkommastellen; @. sehr genau da intern mit Ganzzahl gerechnet wird und dann durch 10.000 dividiert wird -> 4 fixe Nachkommastellen
'Date: Datum; const mydate as date = #mm/tt/jjjj#
'Variant: kann beliebige Datentypen aufnehmen
'Boolean: True, False
'Object: kann Objekte aufnehmen
'Kurzzeichen
Dim i% 'integer
Dim lng& 'long
Dim curr@ 'currency
Dim str$ 'string
Dim i, j, k As Integer 'deklariert nur k als integer! die anderen als Variant -> dim i as integer, j as integer, k as integer
Dim meinBereich As Range
Dim meineZelle As Range
'Set für Objekte (workbook, range…)
End Sub
| - |
21 | Zeilenumbruch im Code | Bricht den aktuellen Befehl um; hilfreich bei längeren Befehlen um den Code übersichtlich zu halten | | Excel VBA [allgemein] | Sub ZeilenUmbruchImCode()
'Zeilenfortführungszeichen
Debug.Print "wirklich langer langer langer Text1" & _
"Text2"
End Sub
| - |
22 | Text in Anführungszeichen | "Text" in Ausgabe | | Excel VBA [allgemein] | Sub TextInAnfuhrungszeichen()
'Text in Anführungszeichen -> 3x"
Debug.Print """Text in Anführungszeichen"""
End Sub
| - |
23 | Variablen übergeben | Zeigt wie man andere Prozeduren aufruft und Variablen übergibt | | Excel VBA [allgemein] | Sub VariablenUbergeben()
Dim Var As Variant
Var = "Hello World"
MsgBox (Var)
Call Aufruf1(Var) 'neues Sub aufrufen mit Variable als Argument
MsgBox (Var) 'bleibt "Hello World"
Call Aufruf2(Var)
MsgBox (Var) 'neuer Text wird zugefügt weil per byRef übergeben wurde und in der Prozedur verändert wurde
End Sub
Sub Aufruf1(ByVal Var1 As Variant)
'ByVal = ByValue Abfrage des Werts, ohne den Originalwert zu verändern
Var1 = Var1 & " neuer Text"
MsgBox Var1 'Hello World neuer Text
End Sub
Sub Aufruf2(ByRef Var1 As Variant)
'ByRef= ByReference Abfrage des Werts, mit der Möglichkeit ihn zu verändern - mit Bedacht verwenden!
Var1 = Var1 & " neuer Text"
MsgBox Var1 'Hello World neuer Text
End Sub
| - |
24 | Absolute Zellbezüge | macht alle Zellbezüge in der Selektion absolut (A1 => $A$1) | | Excel VBA [allgemein] | Sub BezugAbsolut()
Dim rngZelle As Range
For Each rngZelle In Selection
If rngZelle.HasFormula Then
rngZelle.Formula = Application.ConvertFormula(Formula:=rngZelle.Formula, _
fromreferencestyle:=xlA1, toreferencestyle:=xlA1, _
toabsolute:=xlAbsolute)
End If
Next
End Sub
| - |
26 | Text in Spalten | Text am Trenner teilen und in Array fügen | | Excel VBA [allgemein] | Sub TextInSpalten()
Dim var As Variant
var = Split("test, test2", ",") 'explode am Trenner ","
End Sub
| - |
27 | Suchtext in Text suchen | gibt Position des Suchtext im Text aus | | Excel VBA [String] | Sub TextpositionInString()
Dim pos As Integer
pos = InStr("Excelpedia", "e") 'Position eines best. Zeichen finden=4
pos = InStrRev("Excelpedia", "e") 'beginnt von rechts an zu suchen=7
End Sub
| - |
28 | Text schneiden | verschiedene Funktionen um Text zu schneiden | | Excel VBA [String] | Sub TextSchneiden()
Dim str As String
str = Left("Excelpedia", 5) '=Excel
str = Mid("Excelpedia", 2, 4) '=xcel
str = Right("Excelpedia", 5) '=pedia
End Sub ú
| - |
29 | Trim | Leerzeichen entfernen | | Excel VBA [String] | Sub LeerzeichenEntf()
Dim str As String
'Trim 'entfernt Leerzeichen am Anfang und Ende
str = Trim(" Excelpedia ") '=Excelpedia
End Sub
| - |
30 | Replace | ersetzt bestimmte Zeichen | | Excel VBA [String] | Sub ZeichenErsetzen()
Dim str As String
'Replace 'ersetzt best. Zeichen
str = Replace("Excelpedia ist mies", "mies", "super!") '=Excelpedia ist super!
End Sub
| - |
31 | Len | ermittelt Textlänge | | Excel VBA [String] | Sub TextLange()
Dim lange As Integer
'Len 'ermittelt Textlänge
lange = Len("Excelpedia") '=10
End Sub
| - |
32 | Großklein | wandelt Text in Groß- bzw. Kleinschreibung um | | Excel VBA [String] | Sub GrossKlein()
Dim str As String
'Wandelt Text in Groß- bzw. Kleinbuchstaben um
str = "Excelpedia"
str = LCase(str) '=excelpedia
str = UCase(str) '=EXCELPEDIA
End Sub
| - |
33 | Offset | Zeile unter der letzten markieren | | Excel VBA [allgemein] | Sub Offset()
'1. Zeile unter der letzten markieren
lar = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
Cells(lar, 1).Offset(1, 0).EntireRow.Select
End Sub
| - |
34 | Anzahl2 | Anzahl der nicht-leeren Zeilen | | Excel VBA [allgemein] | Sub Anzahl2()
Dim i As Long
i = Application.WorksheetFunction.CountA(Range("A:A")) 'Anzahl der nicht-leeren Zeilen
End Sub
| - |
37 | Blatt vorhanden? | Prüft ob ein bestimmtes Tabellenblatt vorhanden | | Excel VBA [allgemein] | Sub PruefenObWorksheetVorhanden()
'entsprechende Function
If WorksheetExists("Blatt2") Then
MsgBox ("OK")
Else
MsgBox ("no")
End If
End Sub
Function WorksheetExists(WSName As String) As Boolean
'Prüfen ob Worksheet vorhanden
On Error Resume Next
WorksheetExists = Worksheets(WSName).name = WSName
On Error GoTo 0
End Function
| - |
38 | Neues Blatt am Ende | fügt neues Tabellenblatt am Ende ein | | Excel VBA [Spezial] | Sub NeuesBlattAmEnde()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)) '+automat. aktivieren
ws.name = "Neu" 'Tabellenname
End Sub
| - |
39 | Application Funktionen | zeigt verschiedene Funktionen, die sich global auf Excel auswirken | | Excel VBA [allgemein] | application.DisplayAlerts = False 'Warnmeldungen werden abgeschaltet zB das Überschreiben einer Datei _
'bleibt bis zum Neustart aktiv. dh wieder auf True setzen wenn man dies möchte
application.ScreenUpdating = True 'folgt den jeweiligen Arbeitsschritten. Macht das Makro langsamer
application.Calculation = xlCalculationManual 'manuelle Neuberechnung von Formeln
'Kann Makrogeschwindigkeit erhöhen; em Ende wider aktivieren
application.Calculation = xlCalculationAutomatic 'Neuberechnung von allen Formeln im Tabellenblatt sobald sich eine Zelle ändert
application.CalculateFullRebuild ' führt zu Neuberechnung der Formeln etc.
application.EnableEvents = False 'Ignoriert Ereignisse wie worksheet_change
| - |
40 | OnError | diverse Fehlerbehandlungen | | Excel VBA [Error] | Sub OnError()
wiederholen: 'Sprungmarke
On Error Resume Next 'Fehler ignorieren
On Error GoTo 0 'Standard VBA Fehler Prozedur
On Error GoTo meinFehler 'Sprungmarke
i = 1 / 0 'Produziert Fehler
Exit Sub 'verlässt Programm
meinFehler: 'Sprungmarke
Resume 'macht weiter wo Fehler verursacht wurde
Resume Next 'macht mit nächster Zeile nach Fehler weiter
Resume wiederholen 'Fortführung ab Textmarke
If Err.number <> 0 Then
Msg = "Error # " & str(Err.number) & " was generated by " _
& Err.Source & Err.Description
MsgBox Msg, vbInformation
End If
End Sub
| - |
41 | WorksheetEvents | verschiedene Events zu Tabellenblättern | | Excel VBA [allgemein] | Sub WorksheetEvents()
'Workbook Events: Code direkt im Tabellenblatt (nicht Modul)
'Worksheets_Change 'wenn sich im Tabellenblatt Daten ändern
'_SelectionChange: wenn andere Zelle ausgewählt wird
'_BeforeDoubleClick: vor einem Doppelklick
'_BeforeRightClick: vor Rechtsklick
'_Activate: bei Wechsel auf dieses Tabellenblatt
'_Deactivate: wenn man auf ein anderes Tabellenblatt wechselt
'_Calculate: wenn Formeln neu berechnet werden
'Workbook_Open 'wenn Arbeitsmappe geöffnet wird
End Sub
| - |
42 | FensterAnpassen | passt die Fenstergröße an | | Excel VBA [allgemein] | Sub FensterAnpassen()
ActiveWindow.WindowState = xlNormal
With ActiveWindow
.Top = 0 ' obere Pos
.Left = 0 'linke Pos
.Width = 850 'Breite
.Height = 300 'Höhe
End With
End Sub
| - |
43 | Eingabe: InputBox | Dialogbox um Eingabe vom User zu verlangen | | Excel VBA [allgemein] | Sub InputBox()
Dim str As String
'Sub darf nicht so heißen wie das definierte Sub "InputBox"
'InputBox(prompt[, title][, default]) 'default ist der Standardwert der schon eingegeben ist
str = InputBox("test", "Test", "default")
'Beim "Abbrechen" gibt Inputbox eine leere Zeichenfolge zurück ("")
str = application.InputBox("test") 'lässt auf worksheet zugreifen/scrollen
End Sub
| - |
44 | Ausgabe: AdMsgBox | Zusatzinformationen zu MsgBox | | Excel VBA [allgemein] | Sub MessageBox()
'MsgBox(prompt[, buttons] [, title] [, helpfile, context])
'vbOKOnly 'Zeigt nur die Schaltfläche OK an.
'vbOKCancel 'Zeigt die Schaltflächen OK und Abbrechen an.
'vbAbortRetryIgnore 'Zeigt die Schaltflächen Beenden, Wiederholen und Ignorieren an.
'vbYesNoCancel 'Zeigt die Schaltflächen Ja, Nein und Abbrechen an.
'vbYesNo 'Zeigt die Schaltflächen Ja und Nein an.
'vbRetryCancel 'Zeigt die Schaltflächen Wiederholen und Abbrechen an.
'vbCritical 'Zeigt das Symbol Wichtige Meldung an.
'vbQuestion 'Warnung Abfrage ein Symbol.
'vbExclamation 'Warnmeldung ein Symbol.
'vbInformation 'Zeigt das Symbol Informationen an.
'vbNewLine 'beginnt neue Zeile
MsgBox "hello world", vbOKCancel
Call MsgBox("hello world", vbOKCancel)
'The brackets come into play when using the method as a function (ie you want the return value)
Dim msgResult
msgResult = MsgBox("hello world" & vbNewLine, vbOKCancel)
End Sub
| - |
45 | Neues Blatt am Anfang | Fügt neues Tabellenblatt am Anfang ein | | Excel VBA [Spezial] | Sub NeuesBlatAmAnfang()
'neues Blatt
ActiveWorkbook.Worksheets.Add before:=Worksheets(1), count:=1
ActiveSheet.name = "Inhaltsverzeichnis"
End Sub
| - |
46 | Inhaltsverzeichnis mit Hyperlinks | Erstellt ein Inhaltsverzeichnis der Arbeitsmappe und fügt Links zu den jew. Blättern ins Inhaltsverzeichnis und einen Link in jedes Blatt zum Inhaltsverzeichnis | | Excel VBA [allgemein] | Sub InhaltsverzeichnisMitHyperlinks()
application.ScreenUpdating = False
Dim i As Long
Dim ws As Worksheet
'neues Blatt
ActiveWorkbook.Worksheets.Add before:=Worksheets(1), count:=1
ActiveSheet.name = "Inhaltsverzeichnis"
'Inhaltsverzeichnis mit Links
For i = 2 To Sheets.count 'Alle Blätter außer das Inhaltsverzeichnis durchlaufen
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(i - 1, 1), Address:=" ", _
SubAddress:="#'" & Sheets(i).name & "'!A1", TextToDisplay:=Sheets(i).name
Next i
'Auf jeder Seite Link zum Inhaltsverzeichnis
For Each ws In ActiveWorkbook.Worksheets
If ws.name <> "Inhaltsverzeichnis" Then
ws.Activate
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(1, 1), Address:=" ", _
SubAddress:=Sheets(1).name & "!A" & ActiveSheet.index - 1, TextToDisplay:=Sheets(1).name
End If
Next ws
Worksheets(1).Activate
End Sub
| - |
49 | Drucken | Druckt bestimmtes Tabellenblatt | | Excel VBA [allgemein] | Sub Drucken()
'drucken
Sheets("Name").PrintOut
End Sub
| - |
50 | Blatt als pdf | Speichert Tabellenblatt als pdf | | Excel VBA [allgemein] | Sub BlattAlsPdf()
'als pdf exportieren
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="Pfad" & "Datei", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
| - |
51 | Mappe als pdf | Speichert Tabellenblätter der Arbeitsmappe als pdf | | Excel VBA [allgemein] | Sub MappeAlsPdf()
'ganze mappe
Dim Pfad As String
'pfad
ActiveWorkbook.SaveAs FileName:="Pfad" & "Datei" & ".pdf", FileFormat:=xlPDF, _
PublishOption:=xlSheet
End Sub
| - |
52 | Leerzeilen Einfügen | fügt in jeder 2. Zeile eine neue Zeile ein | | Excel VBA [allgemein] | Sub LeerzeilenEinfugen()
'Einfügen
Dim meinBereich As Range
Dim meinCounter As Long
Set meinBereich = Range("A1:A10")
'counter von letzter Zeile im Bereich zu 2 mit Schrittweite -1
For meinCounter = meinBereich.Rows.count To 2 Step -1
meinBereich.Rows(meinCounter).EntireRow.Insert
Next meinCounter
End Sub
| - |
53 | Leerzeilen Löschen | löscht Leerzeilen | | Excel VBA [allgemein] | Sub LeerzeilenLoschen()
'Entfernen
'Löscht jede 2. Zeile
Dim meinBereich As Range
Dim meinCounter As Long
Set meinBereich = Range("A2:A14")
'counter von 2.Zeile zur letzten; Schrittweite 1
For meinCounter = 2 To meinBereich.Rows.count Step 1
'Prüft ob Zeile wirklich leer ist
'Rows(meinCounter).Select
If application.CountA(Rows(meinCounter)) = 0 Then
meinBereich.Rows(meinCounter).EntireRow.Delete
End If
Next meinCounter
End Sub
| - |
54 | Zufallsfunktionen | Zufallszahl erstellen um daraufhin eine zufällige Zelle aus der Selektion auszuwählen | | Excel VBA [Spezial] | Sub zufall()
'Rnd Syntax
'Int ((upperbound - lowerbound + 1) * Rnd + lowerbound)
Dim zufallsreihe As Long
Dim zufallsspalte As Long
Dim rngselect As Range
Dim lar As Long
Dim myrange As Range
Dim mycell As Range
Randomize 'erstellt jedes Mal eine andere Zufallszahl; sonst wird die gleiche erstellt
'If Recalc = 1 Then Application.Volatile = True 'ändert den Wert, wenn Arbeitsmappe neu berechnet wird
If Selection.count < 2 Then
Set rngselect = ActiveSheet.usedrange
Else
Set rngselect = Selection
End If
zufallsreihe = Int(rngselect.Rows.count * Rnd + 1) 'zufällige Reihe
zufallsspalte = Int(rngselect.Columns.count * Rnd + 1) 'zufällige Spalten
rngselect.Cells(1).Offset(zufallsreihe - 1, zufallsspalte - 1).Select
''Schreibt Zufallsdatum in Zelle
'With ActiveSheet
' lar = .Cells(Rows.Count, 1).End(xlUp).Row
' Set myrange = Range(.Cells(2, 1), .Cells(lar, 1))
'
' For Each mycell In myrange
' mycell.Offset(0, 5).Value = Int((42825 - 39083) * Rnd + 39083) 'Datum der letzten 10 J = Zufallszahl zw. 39083 und 42825
' mycell.Offset(0, 5).NumberFormat = "DD.MM.YY"
' Next
'End With
End Sub
| - |
55 | If then | Anweisung der if Bedingung | | Excel VBA [allgemein] | Sub IfThen()
'If then 'besser für binäre Anweisungen; für mehrere Fälle -> Select Case
Const a = 2
If a > 1 Then
'anweisung 1
Else
'anweisung 2
End If
End Sub
| - |
56 | Zelle löschen | verschiedene Arten eine Zelle bzw. dessen Inhalt zu löschen | | Excel VBA [allgemein] | Sub ZelleLoschen()
ActiveCell.ClearContents 'Inhalte löschen
ActiveCell.ClearFormats 'Formate löschen
ActiveCell.Clear 'alle Inhalte löschen
ActiveCell.Delete xlToLeft 'löscht Zelle und verschiebt andere Zellen nach links
End Sub
| - |
57 | gefilterte Tabellen sortieren | sortiert gefilterte Tabelle | | Excel VBA [allgemein] | Sub gefilterteTabelleSortieren()
Dim bereich As String
bereich = "A1" & Range("C6")
'Filter mus bereits gesetzt sein
ActiveWorkbook.Worksheets(1).AutoFilter.Sort.SortFields.Clear 'Sortierung zurücksetzen
ActiveWorkbook.Worksheets(1).AutoFilter.Sort.SortFields.Add _
Key:=Range(bereich), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'aufsteigend sortieren
With ActiveWorkbook.Worksheets(1).AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply 'anwenden
End With
End Sub
| - |
58 | bestimmte Spalte sortieren | sortiert Spalte B | | Excel VBA [allgemein] | Sub allgemeinSortieren()
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("B1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("B:B")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
| - |
59 | Select Case | definiert was bei bestimmten Fällen passieren soll | | Excel VBA [allgemein] | Sub SelectCase()
'select case besser für mehrere Fälle; für binäre -> If-then
Const number As Integer = 8 'als 8 definieren
Select Case number 'Variable
Case 1 To 5
Debug.Print ("Zwischen 1 und inkl. 5")
Case 6, 7, 8
Debug.Print ("Zwischen 6 und inkl. 8")
Case 9 To 10
Debug.Print ("9 oder 10")
'Case Is > 10
Case Else
Debug.Print ("Not between 1 and 10, inclusive")
End Select
End Sub
| - |
60 | Runden | zeigt verschiedene Methoden zum Runden einer Zahl | | Excel VBA [allgemein] | Sub Runden()
Dim x1 As Double, x2 As Double, x3 As Double, x4 As Double
x1 = 0.5
x2 = 1.5
x3 = -0.5
x4 = -1.5
Debug.Print "X", "Int", "Fix", "Cint", "Round", "Function.Round"
Debug.Print x1, Int(x1), Fix(x1), CInt(x1), Round(x1, 0), WorksheetFunction.Round(x1, 0)
Debug.Print x2, Int(x2), Fix(x2), CInt(x2), Round(x2, 0), WorksheetFunction.Round(x2, 0)
Debug.Print x3, Int(x3), Fix(x3), CInt(x3), Round(x3, 0), WorksheetFunction.Round(x3, 0)
Debug.Print x4, Int(x4), Fix(x4), CInt(x4), Round(x4, 0), WorksheetFunction.Round(x4, 0)
'-> WorksheetFunction.Round(x1, 0)
End Sub
| - |
61 | Timer | Stoppuhr; misst die vergangene Zeit | | Excel VBA [allgemein] | Sub Timer()
Dim startzeit As Date
Dim endzeit As Date
Dim test As Variant
startzeit = Now() 'akt Datum inkl. Uhrzeit
'datetime.Timer misst die Zeit in Sekunden nach Mitternacht, daher kann es zu Problem um Mitternacht kommen
'Debug.Print DateTime.Timer
test = InputBox("irgendwas")
endzeit = Now()
MsgBox "Dauer: " & WorksheetFunction.Round((endzeit - startzeit) * 24 * 3600, 0) & " sec" 'inkl. Runden als Integer
End Sub
| - |
62 | kubische Wurzel | individuelle Funktion, die auch in Excel als Funktion verwendet werden kann | | Excel VBA [allgemein] | Function kubischewurzel(zahl)
'Functions können auch als Formel in Tabellen ausgeführt werden
kubischewurzel = zahl ^ (1 / 3)
End Function
| - |
63 | Zelleigenschaften | gibt ein paar Eigenschaften der aktiven Zelle im Direktfenster aus | | Excel VBA [allgemein] | Sub ZellEigenschaften()
Debug.Print ActiveCell.Column 'gibt Spaltennummer zurück
Debug.Print ActiveCell.Row 'gibt Reihennummer zurück
Debug.Print ActiveCell.Address 'gibt absolute Referenz zurück
Debug.Print ActiveCell.HasFormula 'gibt True zurück wenn Ziel Formel enthält
End Sub
| - |
64 | Summe berechnen | verschiedene Methoden die Summe auszugeben | | Excel VBA [allgemein] | Sub Summen()Sub Summen()
Range("B1").Formula = "=SUM(A:A)"
Range("C1").FormulaLocal = "=Summe(A:A)"
WorksheetFunction.Sum (Range("A:A"))
End Sub
| - |
65 | Formeln ersetzen | Ersetzt Formeln durch jeweiligen Zellwert | | Excel VBA [allgemein] | Sub FormelnErsetzen()
Dim mycell As Range
Dim myrange As Range
Set myrange = Selection
For Each mycell In myrange
If mycell.HasFormula Then 'wenn Formel vorhanden
mycell.Formula = mycell.Value 'Ersetzt Formel durch aktuellen Zellwert
End If
Next mycell
'Range("F1").Formula = "=" & "1 + 2"
End Sub
| - |
66 | Verzeichnis auflisten | Listet Verzeichnisstruktur eines Ordners auf | | Excel VBA [allgemein] | | 0,99 |
67 | Tabellenblätter als .csv speichern | Speichert Tabellenblätter die "csv" im Namen haben als .csv | | Excel VBA [Spezial] | | 1,99 |
68 | Mail senden | sendet automatisiert e-mail mit Empfänger, Betreff, Text und Anhang zur Auswahl | | Excel VBA [Spezial] | | 1,99 |
69 | Mappen Öffnen | Öffnet die Mappen, deren Pfad in Zellen steht | | Excel VBA [allgemein] | Sub MappenOeffnen()
Dim Pfad As String
Dim mycell As Range
Dim strOpen As String
With thisworksheet
For Each mycell In Selection
strOpen = mycell.Value 'in dieser Zelle steht der vollständige Pfad zur Mappe
On Error Resume Next
Workbooks.Open FileName:=strOpen 'Öffnen
On Error GoTo 0
Next mycell
End With
ThisWorkbook.Activate
End Sub
| - |
70 | Diagrammnamen anzeigen | Zeigt die Namen der Diagramme im aktiven Blatt an | | Excel VBA [allgemein] | Sub DiagrammNameAnzeigen()
'Diagramme anzeigen
Dim chaDiagram As ChartObject
Dim name As String
For Each chaDiagram In ActiveSheet.ChartObjects
name = name & chaDiagram.name
Next
Debug.Print name
End Sub
| - |
71 | DiagrammQuelle | Ändert Datenbereich und Charttyp für ein bestimmtes Diagramm | | Excel VBA [allgemein] | Sub DiagrammQuelle()
ActiveSheet.ChartObjects("Chart 1").Chart.SetSourceData Source:=Worksheets(1).Range("B10:D10"), PlotBy:=xlRows
End Sub
| - |
72 | Blatt Schützen | Schützt das aktuelle Blatt mit einem Passwort | | Excel VBA [allgemein] | Sub BlattSchutzen()
ActiveSheet.Protect Password:="pass"
'wieder aufheben
'ActiveSheet.Unprotect Password:="pass"
End Sub
| - |
73 | FussZeile | Ändert Fußzeile per Makro | | Excel VBA [Formatierung] | Sub FussZeile()
ActiveSheet.PageSetup.CenterFooter = "Fußzeile" 'Fußzeile
End Sub
| - |
74 | Arbeitsmappe Funktionen | Ein paar Funktionen, die sich direkt auf die Arbeitsmappe auswirken | | Excel VBA [allgemein] | Sub ArbeitsmappeFunktionen()
Workbooks.Add 'neue Arbeitsmappe
sheets("Blatt1").Copy 'erstellt neue Arbeitsmappe mit dem jeweiligen Sheet
sheets("bla").Move After:=Worksheets(Worksheets.count) 'an das Ende verschieben
ActiveWorkbook.SaveAs FileName:="pfad" & "Name.Endung"
ActiveWorkbook.Close savechanges:=True
ActiveWorkbook.Save 'speichern|
Set wpOpen = Workbooks.Open(FileName:="Pfad und Name", updatelinks:=0) 'Mappe öffnen ohne Verknüpfungen zu aktualisieren
Set wpOpen = Workbooks.Open(FileName:="Pfad und Name", ReadOnly:=True) 'Mappe schreibgeschützt öffnen
ActiveWindow.Caption = "Dein gewünschter Name"
End Sub
| - |
75 | Seitenumbruch ausblenden | Seitenumbrüche bei der Druckvorschau ausblenden ("true" für einblenden) | | Excel VBA [Formatierung] | Sub SeitenumbruchAusblenden()
ActiveSheet.DisplayPageBreaks = False 'Seitenumbruch ein/ausblenden; Druckvorschau
End Sub
| - |
76 | ZellFormatierung | Formatierung einer Zelle als Prozent per VBA | | Excel VBA [Formatierung] | Sub ZellFormatierung()
ActiveCell.NumberFormat = "0.00%" 'Formatierung als %
End Sub
| - |
77 | Ersetzen | speziell: Ersetzen der typischen englischen Zahlenformatierung durch das deutsche Format | | Excel VBA [String] | Sub Ersetzen()
'Entfernt Kommas als Tausendertrennzeichen
'Ersetzt Punkt als Dezimaltrennzeichen durch Kommas
ActiveCell.Value = Val(Replace(Replace(ActiveCell.Value, ",", ""), ".", ",")) 'englisches Zahlenformat ins Deutsche
End Sub
| - |
78 | Runterziehen | "Runterziehen" der Werte | | Excel VBA [allgemein] | Sub Runterziehen()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Range("A1:A2")
Set rng2 = Range("A1:A20")
'die Werte in rng1 bis rng2 runterziehen"
rng1.AutoFill Destination:=rng2
End Sub
| - |
79 | Tabellenblattfunktionen | verschiedene Funktionen für das aktive Tabellenblatt | | Excel VBA [allgemein] | Sub TabellenblattFunktionen()
application.Goto Worksheets(1).Range("a1") 'geht auch zu nicht-aktiver Tabelle
Worksheets(1).Activate 'aktiviert 1. Blatt
'sheets(1).Select 'für Worksheets UND Charts
Worksheets(1).Select 'nur für Worksheets
ActiveSheet.usedrange.Select 'benutzten Bereich markieren
ActiveSheet.Range("1:1").Select 'ganze Zeile
ActiveSheet.Range("A:A").Select 'ganze Spalte
ActiveSheet.Range("A1:B8, D1:D8").Select 'voneinander unabhängige Bereiche markieren
ActiveSheet.Range(Cells(1, 1), Cells(2, 3)).Select 'Range von A1 bis C2 selektieren
ActiveSheet.Range("A1:C2").Select 'Range von A1 bis C2 selektieren
ActiveSheet.Range("A1").Offset(1, 2).Select '1 nach unten und 2 nach rechts neben A1
ActiveCell = Date & " " & Time 'Datum Einfügen
Debug.Print (Selection.Row) '1.Reihe der Selektion
Debug.Print (Selection.Column) '1.Spalte der Selektion
Debug.Print Selection.Rows.count 'letzte Reihe
Debug.Print Selection.Columns.count 'letzte Spalte
End Sub
| - |
80 | Tabellenblatt anonymisieren | In diesem Video wird Schritt für Schritt gezeigt wie ein vollständiges Makro erstellt wird um die Inhalte eines Tabellenblatts anonymisiert werden. Die Form wird dabei beibehalten, nur persönliche relevante Daten werden ersetzt. | youtube | Excel VBA [Spezial] | Option Explicit 'man muss jede Variable definieren
Sub Selektion_anonymisieren()
Dim wsHilfsSheet As Worksheet
Dim rngSelektion As Range
Set rngSelektion = Selection
Set wsHilfsSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
'wsHilfsSheet.Name = "Hilfsblatt"
'Selektion durchlaufen
'Alle Inhalte in neues Hilfs-Blatt kopieren
'außer numerische Werte -> umgewandelt werden
Call selektion_durchlaufen(rngSelektion, wsHilfsSheet)
'doppelte Werte entf.
Call doppelte_werte_entf(wsHilfsSheet)
'für jeden eindeutigen Wert -> Wert1 -> KategorieA etc
Call wert_erfinden(wsHilfsSheet)
'-> in Selektion ersetzen
Call string_anonymisieren(rngSelektion, wsHilfsSheet)
Application.DisplayAlerts = False
wsHilfsSheet.Delete
Application.DisplayAlerts = True
'-> Persönliches Makro aufruft
End Sub
Private Sub selektion_durchlaufen(ByVal rng As Range, ByVal ws As Worksheet)
Dim mycell As Range
For Each mycell In rng
'mycell.Select
If IsDate(mycell.Value) Then
'nix machen
ElseIf IsNumeric(mycell.Value) Then
mycell.Value = numerischen_wert_anonymisieren(mycell.Value)
Else
Call zelle_kopieren(mycell, ws) 'wird danach anonymisiert
End If
Next mycell
End Sub
Private Sub zelle_kopieren(ByVal rngZelle As Range, ByVal ws As Worksheet)
Dim laR As Long
With ws
laR = .Cells(Rows.Count, 1).End(xlUp).Row
rngZelle.Copy .Cells(laR + 1, 1)
End With
End Sub
Private Sub doppelte_werte_entf(ByVal ws As Worksheet)
With ws
'.Activate
.Columns(1).RemoveDuplicates
.Cells(1, 1).Delete
End With
End Sub
Function numerischen_wert_anonymisieren(zahl As Double) As Single
'((upperbound - lowerbound + 1) * Rnd + lowerbound)
Dim zahl_neu As Single
Dim intLog As Single
Dim lngObere_grenze As Long
Dim faktor As Integer
faktor = 1
repeat:
If zahl > 0 Then
intLog = log(zahl) / log(10)
intLog = Application.WorksheetFunction.Floor(intLog, 1) + 1
lngObere_grenze = 10 ^ intLog - 1
zahl_neu = ((lngObere_grenze - 0 + 1) * Rnd + 0)
'Debug.Print zahl_neu
ElseIf zahl = 0 Then 'falls 0
zahl_neu = 0
ElseIf zahl < 0 Then 'falls <0
faktor = -1 'wiederholen mit positiver zahl und neg. faktor
zahl = Abs(zahl)
GoTo repeat
End If
numerischen_wert_anonymisieren = Round(zahl_neu * faktor)
End Function
Private Sub wert_erfinden(ByVal ws As Worksheet)
Dim laR As Long
Dim rng As Range
Dim mycell As Range
With ws
laR = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range(.Cells(1, 1), .Cells(laR, 1))
End With
For Each mycell In rng
mycell.Offset(0, 1) = "Kategorie" & wert_erfunden(mycell.Row)
Next mycell
End Sub
Function wert_erfunden(ByVal i As Integer) As String
Dim strSpalte As String
strSpalte = ActiveSheet.Cells(1, i).Address
strSpalte = WorksheetFunction.Substitute(strSpalte, "$", "")
strSpalte = WorksheetFunction.Substitute(strSpalte, "1", "")
wert_erfunden = strSpalte
End Function
Private Sub string_anonymisieren(ByVal rngSelektion As Range, ws As Worksheet)
Dim laR As Long
Dim rng As Range
Dim mycell As Range
Dim strKategorie As String
Dim strZuErsetzen As String
With ws
laR = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range(.Cells(1, 1), .Cells(laR, 1))
End With
For Each mycell In rng
strZuErsetzen = mycell.Value
strKategorie = mycell.Offset(0, 1)
Call wert_ersetzen(rngSelektion, strZuErsetzen, strKategorie)
Next mycell
End Sub
Private Sub wert_ersetzen(ByVal rngSelektion As Range, ByVal strZuErsetzen As String, ByVal strKategorie As String)
Dim sube As Range
Dim strsube As String
Set sube = rngSelektion.Find(what:=strZuErsetzen, lookat:=xlWhole)
'rngSelektion.Select
If Not sube Is Nothing Then
'sube.Select
strsube = sube.Address '1. Ergebnis speichern
Do 'Suchen bis zum 1. Ergebnis
Set sube = rngSelektion.FindNext(sube) 'nächstes Ergebnis wählen
'sube.Select
sube.Value = strKategorie
Loop While sube.Address <> strsube
Else: Exit Sub
End If
End Sub
| - |
81 | PDF per Mail | Versendet aktuelle Seite als pdf im Anhang per mail mit benutzerdefiniertem Text und Betreff | youtube | Excel VBA [Spezial] | Sub pdf_per_mail()
Dim pdf As String
pdf = pdf_erstellen
Call permail(pdf)
Kill (pdf) 'pdf wieder löschen
End Sub
Function pdf_erstellen()
Dim pdf As String
Dim sep As String
sep = Application.PathSeparator
pdf = ThisWorkbook.Path & sep & ThisWorkbook.Name & "_" & Date & Format(Time, "hhmm") & ".pdf" 'Speicherpfad
On Error Resume Next
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdf, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
On Error GoTo 0
pdf_erstellen = pdf
End Function
Sub permail(ByVal pdf As String)
Dim objOutlook As Object
Dim objMail As Object
Dim myAttachments
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Set myAttachments = objMail.Attachments
With objMail
.To = "office@dfinvesting.com"
.Subject = "Excelpedia + youtube"
.Body = "Sehr geehrte Damen und Herren, " & vbNewLine _
& vbNewLine _
& "Danke für das Video zum automatischen Versenden von mails." & vbNewLine _
& "lg"
myAttachments.Add pdf 'Anhang
'Nachricht zur Kontrolle anzeigen
.Display
'Oder direkt senden
'.Send
End With
End Sub
| - |
82 | Schleifen | Arbeitsweise von Schleifen | | Excel VBA [allgemein] | Sub Schleifen()
While i < 100
'Durchläutft Anweisungen solange best. Bed. zutrifft
Wend
Do While i < 1 'Bedingung
i = i + 1
Loop 'führt Schleife aus solange Bedingung zutrifft
Do Until i > 1 'Bedingung
i = i + 1
Loop 'führt Schleife aus BIS Bedingung zutrifft
End Sub
| - |
83 | Formate | Zelle formatierung oder Zahl umwandeln | | Excel VBA [Formatierung] | Sub Formatierung()
'Abs 'Betrag
'CDbl 'wandelt Ausdruck in Double 'umwandeln
'CInt 'wandelt Ausdruck in Integer um
'CLng(Variable) 'wandelt Ausdruck in Long um
'FormatNumber 'liefert eine Zahl als String zurück
'FormatPercent 'liefert eine Zahl als String formatiert als Prozent zurück
'FormatCurrency, DateTime …
End Sub
| - |
84 | Functions | nützliche Funktionen | | Excel VBA [allgemein] | Sub ProgrammeFunctions()
'Let 'weist einer Variable einen Wert zu
IsEmpty (variable) 'liefert True wenn keine Variable initialisiert wurde
IsError 'liefert True wenn Variable mit Fehler
IsNull 'liefert True wenn keine gültigen Daten in der Variable; (Null direkt ist weder True noch false, nur Variant kann damit umgehen)
IsNumeric , IsDate '…
application.WorksheetFunction.IsText (variable)
UCase 'liefert einen String in Großbuchstaben
LCase 'liefert einen String in Kleinbuchstaben
TypeName ("Variable") 'Namen des Typs der Variable als String zB TypeName(ActiveCell.Value) -> "String", TypeName(ActiveCell) -> "Range"
'Exit Sub, For 'Sub, For schleife vorzeitig beenden
GoTo textmarke 'geht zu textmarke:
'textmarke:
'Anweisung
End Sub
| - |
85 | Blatt als csv | Blatt als csv speichern | | Excel VBA [Spezial] | Sub blatt_als_csv(ws As Worksheet)
' worksheet muss übergeben werden
sheets(ws.name).Copy
application.DisplayAlerts = False
ActiveWorkbook.SaveAs FileName:=SaveToDirectory & ws.name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
application.DisplayAlerts = True
End Sub
| - |
86 | Suchen | Durchläuft die 1. Spalte und sucht nach dem jew. 1. Treffer | | Excel VBA [allgemein] | Sub Suchen()
'Findet 1. Treffer zum Suchbegriff
Dim SuBereich As Range
Dim s As String
Dim lar As Long, i As Long
With ActiveSheet
lar = .Cells(Rows.count, 1).End(xlUp).Row
For i = 1 To lar
s = .Cells(i, 1).Value ' Suchbegriff
Set SuBereich = sheets(1).Range("B:Z"). _
Find(s, lookat:=xlWhole)
If sube Is Nothing Then
.Cells(i, 2).Value = Date
End If
Next i
End With
End Sub
| - |
87 | Erweitertes Suchen | Sucht nach weiteren Treffern | | Excel VBA [allgemein] | Sub FindErweitert()
'Findet alle Treffer
Dim sube As Range
Dim su As String
Dim strsube As String
su = InputBox("Suchbegriff")
If su = "" Then
Exit Sub
End If
Cells.Interior.Color = xlNone
Set sube = Range("A:A").Find(su)
If Not sube Is Nothing Then
' sube.Select
strsube = sube.Address '1. Ergebnis speichern
Do 'Suchen bis zum 1. Ergebnis
Set sube = Cells.FindNext(sube) 'nächstes Ergebnis wählen
sube.Interior.ColorIndex = 3
Loop While sube.Address <> strsube
Else: Exit Sub
End If
End Sub
| - |
88 | Rng Funktionen | Einige Funktionen, die mit Range zu tun haben | | Excel VBA [allgemein] | Sub RngFunctions()
'Set Rng = Union(rng1, rng2) 'verbindet mehrere Bereiche; kopieren nicht möglich!
ActiveSheet.Cells.SpecialCells (xlCellTypeConstants) 'nur Konstante werden angesprochen, keine Formeln
'set sube = .cells.find(what:="", lookin:= xlvalues, lookat:= xlwhole) 'xlvalues sucht nur in Werten, xlwhole heißt komplette übereinstimmung (xlpart ähnliche Werte)
'set sube = cells.FindNext (After) 'After=Sube 'setzt Suche fort die mit find gestartet wurde
'Die Zelle, hinter der Sie suchen möchten. Dies entspricht der Position der aktiven Zelle, wenn eine Suche auf der Benutzeroberfläche erfolgt. Achten Sie darauf, dass After eine einzelne Zelle im Bereich sein muss. Beachten Sie, dass die Suche hinter dieser Zelle startet. Die angegebene Zelle wird erst durchsucht, wenn die Methode bei dieser Zelle angelangt ist. Wenn dieses Argument nicht angegeben wird, beginnt die Suche hinter der Zelle in der oberen linken Ecke des Bereichs.
'Application.CutCopyMode = False ' leert Zwischenablage und entfernt den Laufbalken um kopierten Bereich
End Sub
| - |
89 | Suchen & Ersetzen | Ersetzt bestimmte Werte im zuvor kopierten Bereich | | Excel VBA [allgemein] | Sub SuchenErsetzen()
'Suchen Ersetzen
Selection.Copy ' kopieren
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False ' nur werte einsetzen
' " =" entfernen
Selection.Replace what:=" =", replacement:="=", lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
application.CutCopyMode = False ' Rahmen um kopierten Bereich entfernen
End Sub
| - |
90 | Anfänger | paar Sachen, die man als Anfänger leicht verbessern kann | | Excel VBA [allgemein] | Sub Anfaenger()
'im Automator:
Range("A1").Select
Selection.Copy
Range("A2").Paste
'manuell - ohne select
Range("A1").Copy Range("A2")
'oder
Range("A2").Value = Range("A1").Value
End Sub
| - |
91 | Duplikate entfernen | Entfernt Duplikate in Spalte A | | Excel VBA [allgemein] | Sub DuplikateEntfernen()
'Sortieren, Duplikate entfernen
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
| - |
92 | Pivot Tabellen | Durchläuft alle worksheets und darin alle Pivot Tabellen und gibt bestimmte Metadaten aus | | Excel VBA [allgemein] | Sub PivotTables()
'durchläuft alle worksheets und darin alle pivot tabellen und gibt gewisse Metadaten darüber aus
Dim ws As Worksheet
Dim pt As PivotTable
Dim mycell As Range
'Worksheets.Add
'ActiveSheet.Name = "Pivot Übersicht"
Range("A1:G1") = Array("Pivot-Name", "Tabellenblatt", "Zellbereich", "Cache-index", _
"Speicherort der Quelldaten", "Anzahl der Zeilen", "Anzahl Objekte")
Set mycell = ActiveSheet.Range("A2")
For Each ws In Worksheets
For Each pt In ws.PivotTables
mycell.Offset(0, 0) = pt.name
mycell.Offset(0, 1) = pt.Parent.name
mycell.Offset(0, 2) = pt.TableRange2.Address
mycell.Offset(0, 3) = pt.CacheIndex
mycell.Offset(0, 4) = application.ConvertFormula(pt.PivotCache.SourceData, xlR1C1, xlA1)
mycell.Offset(0, 5) = pt.PivotCache.RecordCount
mycell.Offset(0, 6) = pt.TableRange2.count
Set mycell = mycell.Offset(1, 0)
Next pt
Next ws
ActiveSheet.usedrange.EntireColumn.AutoFit
ActiveSheet.Range("A1").Select
End Sub
| - |
93 | Pivot Summe | Setzt die Funktion einer PivotTabelle auf Summe (statt standardmäßig Durchschnitt) | | Excel VBA [allgemein] | Sub PivotTitelSummeAnpassen()
'setzt die Funktion einer PivotTabelle auf Summe
Dim pt As PivotTable
Dim pf As PivotField
On Error Resume Next
Set pt = ActiveSheet.PivotTables(ActiveCell.PivotTable.name)
If pt Is Nothing Then
MsgBox ("Zellmarkierung in PivotTable setzen")
Exit Sub
End If
For Each pf In pt.DataFields
'pf.Caption = pf.SourceName & Chr(32) 'Schreibt den Titel für die PivotZelle aus der Quelle mit " " am Ende; ASCII Code für Leerzeichen
pf.Function = xlSum 'Funktion auf Summe
Next pf
End Sub
| - |
94 | Pivot Format | Format innerhalb einer PivotTabelle übernehmen | | Excel VBA [allgemein] | Sub PivotFormatierungUebernehmen()
Dim pt As PivotTable
Dim pf As PivotField
Dim srcRange As Range
Dim strFormat As String
Dim strLabel As String
Dim i As Integer
On Error Resume Next
Set pt = ActiveSheet.PivotTables(ActiveCell.PivotTable.name)
If pt Is Nothing Then
MsgBox ("Zellmarkierung in PivotTable setzen")
Exit Sub
End If
Set srcRange = Range(application.ConvertFormula(pt.SourceData, xlR1C1, xlA1)) 'von R1C1 nach A1 konvertieren
For i = 1 To srcRange.Columns.count
'Namen der Spalte und Zahlenformat im Quelldatenbereich ermitteln
strLabel = srcRange.Cells(1, i).Value
strFormat = srcRange.Cells(2, i).NumberFormat
For Each pf In pt.DataFields
If pf.SourceName = strLabel Then
pf.NumberFormat = strFormat
End If
Next pf
Next i
End Sub ••••ˇˇˇˇ
| - |
95 | Folder Dialog | Öffnet einen Dialog, der den Pfad zum gewählten Ordner ausgibt | | Excel VBA [allgemein] | | 0,99 |
96 | File Dialog | Öffnet einen Dialog, der den Pfad zur gewählten Datei ausgibt | | Excel VBA [allgemein] | | 0,99 |
98 | Arbeitsblattevents | verschiedene Subs, die bei Events aufgerufen werden zB Drucken, Doppelklick etc | | Excel VBA [allgemein] | 'WICHTIG: Code dirket beim Blatt bzw. Workbook einfügen - nicht in einem Modul
Private Sub Workbook_BeforePrint(Cancel As Boolean)
'Zeilenhöhe ändern
With Worksheets(1)
ActiveSheet.Cells.RowHeight = 12.75
ActiveSheet.Rows(1).RowHeight = 40
End With
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If ActiveWindow.Zoom <> 100 Then
ActiveWindow.Zoom = 100
Else
ActiveWindow.Zoom = 200
End If
'weil nach Doppelklick der Bearbeitungsmodus aktiviert wird
ActiveSheet.Cells(ActiveCell.Row + 1, ActiveCell.Column).Select
End Sub
| - |
99 | Array Funktionen | diverse Möglichkeiten ein Array zu erstellen und zu bearbeiten | | Excel VBA [allgemein] | Option Explicit
Dim varDat As Variant
Dim lngZeile As Long
Dim lngSpalte As Long
Dim lngZeileMax As Long
Dim lngSpalteMax As Long
Sub Array1()
With Blatt1
lngZeileMax = .UsedRange.Rows.Count
lngSpalteMax = .UsedRange.Columns.Count
'Einlesen
varDat = .UsedRange 'mit beliebigem Range Objekt befüllen
'Array, Feld für Feld bearbeiten
For lngZeile = 1 To lngZeileMax 'LBound(varDat, 1) To UBound(varDat, 1) 'die untere bzw. obere Grenze
For lngSpalte = 1 To lngSpalteMax 'LBound(varDat, 2) To UBound(varDat, 2)
varDat(lngZeile, lngSpalte) = varDat(lngZeile, lngSpalte) * 2
Next lngSpalte
Next lngZeile
'ausleeren
.Range(.Cells(1, 1), .Cells(lngZeileMax, lngSpalteMax)) = varDat 'Maße müssen übereinstimmen
End With
End Sub
Sub Array2()
'Transponieren und Preserve
'Preserve geht nur für die letzte Dimension
Dim n, m As Integer
n = 2
m = 1
Dim arrCity() As Variant
ReDim arrCity(1 To n, 1 To m) '2x1 Matrix
m = m + 1
ReDim Preserve arrCity(1 To n, 1 To m) '2x2 Matrix
arrCity = Application.Transpose(arrCity)
n = n + 1
ReDim Preserve arrCity(1 To m, 1 To n) '2x3 Matrix
arrCity = Application.Transpose(arrCity) '3x2 Matrix
End Sub
Sub Array3()
'werte aus array in zelle schreiben
Dim SuchArray
Dim i As Integer
SuchArray = Array("*incoming*", "*withdraw*", "*service*", "*late*", "*interest*") 'Suchen
For i = LBound(SuchArray) To UBound(SuchArray) 'Index beginnt bei 0
ActiveSheet.Cells(i + 1, 1).Value = SuchArray(i)
Next
End Sub
Sub arr()
Dim MeinArray() As Variant
ReDim MeinArray(9, 9) ' deklariert eine 9x9 Matrix
MeinArray(1, 1) = "test"
ReDim MeinArray(1 To 12, 1 To 12) 'neues Array mit neuen Dimensionen, alte wird gelöscht
MeinArray(1, 1) = "test"
ReDim Preserve MeinArray(1 To 12, 1 To 12) 'altes Array von 1-9 wird beibehalten
End Sub
| - |
100 | Ziegenproblem | Eine stochasische Herangehensweise an das berühmte Ziegenproblem oder Drei-Türen-Problem | | Excel VBA [Spezial] | | - |
101 | bestimmte Spalten als csv kopieren | Kopiert selbst zu wählende Spalten von einem bestehenden Tabellenblatt und speichert diese als .csv.
Anleitung: im Tab "Ziel" die Spaltenbezeichnungen, der Spalten, die exportiert werden sollen in die 1. Zeile schreiben. Das Makro per Button starten. Im Code anpassbar: Namen der Blätter, Trennzeichen für csv, Export mit oder ohne überschrift | | Excel VBA [Spezial] | | 9,99 |
102 | Grafiken einfügen | fügt Bilder anhand eines Dateinamens ein (zB ID in bestimmter Zelle). Man erspart sich so das manuelle Einfügen von Grafiken | | Excel VBA [Spezial] | | 9,99 |
103 | Blatt als pdf | Speichert Tabellenblatt als pdf (inkl. Errorhandling und Überprüfen auf Sonderzeichen im Dateinamen) | | Excel VBA [Spezial] | | 1,99 |
105 | Blätter zu 1 pdf zusammenfassen | Speichert bestimmte Tabellenblätter als 1 pdf (inkl. Errorhandling und Überprüfen auf Sonderzeichen im Dateinamen) | | Excel VBA [Spezial] | | 2,99 |