MS Visual Basic for Applications

Allgemein

' Die Angabe LW:\Pfad\ muss durch die echten Laufwerks- und Pfadnamen ersetzt werden.

Alle Variablen müssen deklariert werden
Option Explicit

Bildschirm-Aktualisierung ausschalten
Application.ScreenUpdating = False

Warten 10 Sekunden
Application.Wait (Now + TimeValue("0:00:10"))

Text der Markierung formatieren
With Selection.Font
.Name = "Arial"
.Size = 12
.Bold = True
End With

Message-Box
Option Explicit

Sub Meldung()
Dim strMeldung, strTitel, strText As String
Dim Style, Antwort

strTitel = "Demo"
strMeldung = "Möchten Sie fortfahren?"

Style = vbYesNo + vbCritical' Buttons
' Style = vbOKOnly + vbCritical ' Buttons

Antwort = MsgBox(strMeldung, Style, strTitel)

' Rückgabewerte:
' vbOK 1 OK
' vbCancel 2 Abbrechen
' vbAbort 3 Abbruch
' vbRetry 4 Wiederholen
' vbIgnore 5 Ignorieren
' vbYes 6 Ja
' vbNo 7 Nein

If Antwort = vbYes Then
strText = "Ja"
Else
strText = "Nein"
End If

MsgBox (strText)

End Sub

Meldung in der Statusbar anzeigen
Application.StatusBar = "Hinweis:"

Ausgabe ins Direktfenster als Alternative zur Messagebox
' Menü Entwicklertools, Visual Basic, Menü Ansicht, Direktfenster (VBA: <Strg>+G)
Sub StartordnerAnzeigen()
Debug.Print Application.StartupPath
End Sub
' Die Ausgaben im Direktfenster können kopiert werden.
' Manchmal ist das Direktfenster am unteren Fensterrand auf Höhe 0 verkleinert.
' Dann einfach mit der Maus aufziehen.

Datei kopieren mit Ziel überschreiben
Dim fs As Object
Dim strDateiName As String

strDateiName = "LW:\Pfad\Datei.xls"

On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
fs.copyfile strDateiname, Environ("TEMP") & "\Temp.xls", True
Set fs = Nothing
On Error GoTo 0

Datei verschieben
Dim fs As Object
Dim strDateiName, strPfadQuelle, strPfadZiel As String

strDateiName = "Datei.txt"
strPfadQuelle = "LW1:\Pfad\"
strPfadZiel = "LW2:\Pfad\"

On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
fs.movefile strPfadQuelle & strDateiName, strPfadZiel & strDateiName
Set fs = Nothing
On Error GoTo 0

Datei umbenennen
' Der Quell- und Ziel-Pfad sind identisch.
Dim fs As Object
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
fs.MoveFile "LW:\Pfad\Datei1.txt", "LW:\Pfad\Datei2.txt"
Set fs = Nothing
On Error GoTo 0

Datei löschen mit dem FileSystemObject
Dim fs As Object
Dim strDateiName As String

strDateiName = "LW:\Pfad\Datei.xls"

On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
fs.DeleteFile (strDateiName)
Set fs = Nothing
On Error GoTo 0

Datei löschen mit kill
Kill LW:\Pfad\Datei.xls

Datei-Zugriff anzeigen
Dim fs, f As Object
Dim strMessage As String

Set fs = CreateObject("Scripting.FileSystemObject")

Set f = fs.GetFile("LW:\Pfad\Datei.xls")

strMessage = f.Name & " auf Laufwerk " & UCase(f.Drive) & vbCrLf
strMessage = strMessage & "Erstellt: " & f.DateCreated & vbCrLf
strMessage = strMessage & "Letzter Zugriff: " & f.DateLastAccessed & vbCrLf
strMessage = strMessage & "Letzte Änderung: " & f.DateLastModified

MsgBox strMessage, 0, "Datei-Zugriff"

Set fs = Nothing
Set f = Nothing

Prüfung auf Vorhandensein einer Datei
Dim fs As Object
Dim bolFE As Boolean

Set fs = CreateObject("Scripting.FileSystemObject")

bolFE = fs.FileExists("LW:\Pfad\Datei.xls")

If bolFE = True Then
MsgBox ("Die Datei ist vorhanden.")
Else
MsgBox ("Die Datei ist nicht vorhanden.")
End If

Set fs = Nothing

Anlegen eines Unterverzeichnisses
' Das Verzeichnis LW:\Pfad muss vorhanden sein.
If Dir("LW:\Pfad\Test", vbDirectory) = "" Then
MkDir ("LW:\Pfad\Test")
End If

Anlegen eines Unterverzeichnisses im Homeverzeichnis
Dim strPfad As String
Dim strUser As String
Dim fs

Set fs = CreateObject("Scripting.FileSystemObject")

strUser = Environ("USERPROFILE")
strPfad = strUser & "\Eigene Dateien" & "\Test" '& "\"

If fs.folderexists(strPfad) = False Then
MkDir strPfad
MsgBox "Der Ordner: " & strPfad & " wurde angelegt."
End If

Set fs = Nothing

Ermitteln der Indizes und Werte zu einer Datei
Option Explicit

Sub DateiProperties()

Dim objShell As Object
Dim objFolder As Object
Dim objItem As Object
Dim intIndex As Integer

Set objShell = CreateObject("Shell.Application") ' Windows Shell

Set objFolder = objShell.Namespace("LW:\Pfad\") ' Pfad
Set objItem = objFolder.ParseName("Bild.jpg") ' Datei

' Ausgabe im Direktfenster (VBA: <Strg> + G)
For intIndex = 0 To 300
Debug.Print intIndex & " - " & objFolder.GetDetailsOf(Null, intIndex) & ": " & _
objFolder.GetDetailsOf(objItem, intIndex)
Next intIndex

Set objItem = Nothing
Set objFolder = Nothing
Set objShell = Nothing

End Sub

Informationen einer Bild-Datei auslesen
Option Explicit

Sub BildWin()
' Die Indexe können sich bei den Funktionsupdates von Windows ändern.

Dim objShell As Object
Dim objFolder As Object
Dim objDatei As Object
Dim strBreite, strHöhe, strBittiefe As String
Dim strPfad, strDatei, strMessage As String

strPfad = "LW:\Pfad"
strDatei = "Bild.jpg"

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strPfad)

For Each objDatei In objFolder.Items
If objDatei = strDatei Then
  strBreite = objFolder.GetDetailsOf(objDatei, 176) ' Ausgabe: ?nnn Pixel
  strHöhe = objFolder.GetDetailsOf(objDatei, 178)

  strBreite = Right(strBreite, Len(strBreite) - 1) ' ? links vom Wert entfernen
  strHöhe = Right(strHöhe, Len(strHöhe) - 1)

  If Right(strBreite, 6) = " Pixel" Then ' Pixel rechts vom Wert entfernen
   strBreite = Left(strBreite, Len(strBreite) - 6)
  End If

  If Right(strHöhe, 6) = " Pixel" Then
   strHöhe = Left(strHöhe, Len(strHöhe) - 6)
  End If

  strBittiefe = objFolder.GetDetailsOf(objDatei, 174)

  Exit For ' Verlassen der Schleife, wenn die Datei gefunden wurde
End If
Next

MsgBox "Höhe: " & strHöhe & " ; Breite: " & strBreite & " ; Bittiefe: " & strBittiefe

Set objShell = Nothing
Set objFolder = Nothing
Set objDatei = Nothing

End Sub

Deutsche Umlaute in das MS-DOS-Format umwandeln
Dim strAlt, strNeu As String
Dim strByte As String * 1
Dim strKorr As String * 1
Dim intZähler As Integer
Dim bolFehler As Boolean

bolFehler = False

For intZähler = 1 To Len(strAlt)
strByte = Mid(strAlt, intZähler, 1)

If Asc(strByte) > 127 Then
  Select Case strByte
   Case "Ä"
    strKorr = Chr(142)
   Case "Ö"
    strKorr = Chr(153)
   Case "Ü"
    strKorr = Chr(154)
   Case "ä"
    strKorr = Chr(132)
   Case "ö"
    strKorr = Chr(148)
   Case "ü"
    strKorr = Chr(129)
   Case "ß"
    strKorr = Chr(225)
   Case Else
    strKorr = " "
    bolFehler = True
  End Select

  strNeu = Left(strNeu, intZähler - 1) & strKorr & Right(strAlt, Len(strAlt) - intZähler)
End If
Next intZähler

Mehrfaches Ersetzen eines Zeichens in einer Zeichenkette
strName = Replace(strName, "\", "/")

Trennen einer Zeichenkette vor und nach einem Zeichen
strLand = Left(strText, InStr(strText, "-") - 1)
strPLZ = Right(strText, Len(strText) - (InStr(strText, "-")))

Text-Datei in Notepad laden
Dim dblReturn As Double

dblReturn = Shell("C:\Windows\system32\notepad.exe LW:\Pfad\Datei.txt", vbNormalFocus)

Standard-Programm zu einem Dateityp ermitteln
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function FindExecutable Lib "shell32.dll" _
  Alias "FindExecutableA" ( _
  ByVal lpFile As String, _
  ByVal lpDirectory As String, _
  ByVal lpResult As String) As Long
#Else
Private Declare Function FindExecutable Lib "shell32.dll" _
  Alias "FindExecutableA" ( _
  ByVal lpFile As String, _
  ByVal lpDirectory As String, _
  ByVal lpResult As String) As Long
#End If

Public Function StandardProgramm(Dateipfad As String) As String
' Diese Funktion ermittelt das einem Dateityp zugeordnete Standardprogramm.
Dim strTemp As String
Dim intZahl As Integer
Dim strPfad As String

strPfad = Space$(260)

' Wenn die Datei nicht existiert, eine temporäre Datei erzeugen.
If CreateObject("Scripting.FileSystemObject").FileExists(Environ("USERPROFILE") & "\Eigene Dateien\" _
& Dateipfad) = False Then
  strTemp = Environ("USERPROFILE") & "\Eigene Dateien\" & Dateipfad
  intZahl = FreeFile()
  Open strTemp For Output As intZahl
  Close intZahl
  FindExecutable strTemp, vbNullString, strPfad
Else
  FindExecutable Dateipfad, vbNullString, strPfad
End If

strPfad = Left$(strPfad, InStr(strPfad, vbNullChar) - 1)

If InStr(strPfad, Dateipfad) > 0 Then
strPfad = vbNullString
End If

On Error Resume Next
Kill strTemp
On Error GoTo 0

StandardProgramm = strPfad

End Function

Sub Start()
Dim strDatei As String
Dim strProgramm As String

' Pfad zum Standardbrowser auslesen (Datei nicht vorhanden.)
' strDatei = "Test.htm"

' Pfad zur WINWORD.EXE auslesen (Datei nicht vorhanden.)
' strDatei = "Test.doc"

' Pfad zum PDF-Programm auslesen (Datei vorhanden.)
strDatei = "C:\Daten\Test.pdf"

strProgramm = StandardProgramm(strDatei)

If strProgramm <> "" Then
MsgBox strProgramm
Else
MsgBox "Kein Standardprogramm gefunden."
End If

End Sub

HTML-Seite im Internet Explorer laden
' Deklaration für das Maximieren des Fensters
Option Explicit
#If VBA7 Then
Declare PtrSafe Sub ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long)
#Else
Declare Sub ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long)
#End If

Sub HTML()
Dim objIE As Object ' Internet Explorer
Dim strDateiname As String

strDateiname = "LW:\Pfad\Test.htm"

Set objIE = CreateObject("InternetExplorer.Application")

' Eigenschaften des Fensters:
' objIE.FullScreen = True ' besser das Fenster maximieren (siehe unten)
' objIE.Toolbar = False
' objIE.StatusBar = False
' objIE.MenuBar = False
' objIE.Resizable = True

' Position und Größe des Fensters:
' objIE.Top = 0
' objIE.Left = 0
' objIE.Width = 1024
' objIE.Height = 768

objIE.Visible = True ' Das Fenster sichtbar machen.

objIE.Navigate strDateiname

' Warten bis die Seite geladen ist
Do While objIE.Busy
Loop

' Das Fenster maximieren.
ShowWindow objIE.hwnd, 3' muss außerhalb von Sub deklariert werden (siehe oben)

' objIE.Quit ' den Internet Explorer schließen

Set objIE = Nothing

End Sub

Excel-Makro aus Batch-Datei starten
' Alle Dateien sind im gleichen Verzeichnis.

' Inhalt der Batch-Datei Excel.bat:
cscript Start.vbs

' Inhalt der Script-Datei Start.vbs:
Option Explicit

Dim objExcel, objWorkbook As Object
Dim dateiname As String

dateiname = "LW:\Pfad\Meldung.xlsm"

Set objExcel = CreateObject("Excel.Application")

objExcel.visible = true

' Die Datei schreibgeschützt öffnen: Dateiname, UpdateLinks, ReadOnly
Set objWorkbook = objExcel.Workbooks.Open (dateiname, false, true)

objExcel.Run "MsgZeigen"

objExcel.Quit

Set objWorkbook = Nothing
Set objExcel = Nothing

' Makro MsgZeigen in der Datei Meldung.xlsm:
MsgBox ("Es tut.")

Anzahl der zuletzt verwendeten Dateien einstellen
' Die Liste wird beim Verkleinern und auch beim Vergrößern sofort angepasst.
RecentFiles.Maximum = 10

VBA 64-Bit

Prüfung auf 32-Bit oder 64-Bit MS Office
Sub Version()
#If VBA7 Then
#If Win64 Then
Debug.Print "64-Bit Office ab Version 2010, 64-Bit Windows"
#Else
Debug.Print "32-Bit Office ab Version 2010, 32- oder 64-Bit Windows"
#End If
#Else
Debug.Print "32-Bit Office vor Version 2010"
#End If
End Sub

Deklaration für 32-Bit und 64-Bit MS Office
' Das Beispiel gibt den System-Pfad aus.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetSystemDirectoryA Lib "kernel32" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
#Else
Private Declare Function GetSystemDirectoryA Lib "kernel32" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
#End If

Public Function GetSystemDirectory() As String
Dim lngLen As Long, lpBuffer As String, nSize As Long

nSize = 255
lpBuffer = String(nSize, vbNullChar)
lngLen = GetSystemDirectoryA(lpBuffer, nSize)
GetSystemDirectory = Left(lpBuffer, lngLen)
End Function

Sub Systempfad()
MsgBox GetSystemDirectory()
End Sub

Excel

Datei für persönliche Makros
%AppData%\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLSB
' Zum Bearbeiten: Menü Ansicht, Fenster, Einblenden

Makro beim Öffnen der Arbeitsmappe ausführen
' Leere Tabelle als *.xlsm speichern
' Menü Entwicklertools, Visual Basic, rechte Maustaste auf DieseArbeitsmappe, Code anzeigen
Private Sub Workbook_Open()
Call Anzeigen' Starten des Makros Anzeigen
MsgBox ("Ende")
End Sub
' Das AutoOpen-Makro kann unterdrückt werden,
' wenn beim Öffnen der Arbeitsmappe die <Shift>-Taste zusätzlich gedrückt wird.

Schaltfläche für ein Makro in eine Tabelle einfügen
Eine Zelle aktivieren
Menü Entwicklertools
Bereich Steuerelemente
Einfügen Steuerelemente einfügen
Formularsteuerelemente
Schaltfläche (Formularsteuerelement)
Makro zuweisen Schaltfläche1_Klicken' oder vorhandenes Makro

Sub Schaltfläche1_Klicken()' in Modul1 Allgemein
MsgBox ("Test")
End Sub

Einfügen aus der Zwischenablage ohne Formate
Sub EinfügenOhneFormate()
ActiveSheet.PasteSpecial Format:="Text"
End Sub

ASCII-Nummern einer Zeichenkette im Direktfenster ausgeben
Option Explicit

Sub FindeASCII()

Dim i As Integer
Dim strText As String

strText = ActiveCell.Value' Text aus der aktiven Zelle

For i = 1 To Len(strText)
Debug.Print Asc(Mid(strText, i, 1)) ' Ausgabe im Direktfenster (VBA: <Strg>+G)
Next

End Sub

Sonderzeichen in der aktuellen Zelle anzeigen
Option Explicit

Sub Sonderzeichen()

Dim strText As String
Dim strByte As Byte

strText = ActiveCell.Value

For i = 1 To Len(strText)
strByte = Asc(Mid(strText, i, 1))
If strByte < 32 Or strByte > 122 Then ' < Leerzeichen oder > z
MsgBox (strText & "*" & strByte)
End If
Next

End Sub

Darstellung im Fenster anpassen
ActiveWindow.DisplayZeroes = False
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False

Langen Dateiname der Arbeitsmappe ermitteln
Dim strDateiname As String

strDateiname = ActiveWorkbook.FullName

Dateinamen in ein Formular (Listbox) beim Öffnen der Arbeitsmappe einlesen
Option Explicit

Private Sub Workbook_Open()
Dim strPfad, strDateiname As String

strPfad = "LW:\Pfad\"
strDateiname = Dir(strPfad & "*.txt")

With frmStart' das Formular Start
.lblPfad.Caption = strPfad ' Das Label wird dem Pfad gefüllt.

.lstDatei.Clear ' Die Listbox Datei wird geleert.
Do While strDateiname <> "" ' Die Listbox Datei wird mit allen Dateinamen gefüllt.
.lstDatei.AddItem (strDateiname)
strDateiname = Dir' Den nächsten Dateiname einlesen.
Loop

.Show ' Das Formular Start anzeigen.
End With

End Sub

Arbeitsmappe im Dialog öffnen
Dim varFile As Variant

varFile = Application.GetOpenFilename("Excel-Dateien (*.xls), *.xls")
If varFile = False Then Exit Sub
Workbooks.Open varFile

Beim Öffnen der Arbeitsmappe eine Tabelle und Zelle auswählen
Private Sub Workbook_Open()
Worksheets("Start").Activate
Range("B9").Select
End Sub

Geöffnete Arbeitsmappe aktivieren
Application.Windows("Datei.xls").Activate

Neue Arbeitsmappe erstellen
strDateiname = "Datei.xls"

Set NeueDatei = Workbooks.Add

' Löschen der leeren Tabellenblätter ohne Nachfrage
' Die Tabellenblätter müssen vorhanden sein. (Excel-Standard)
Application.DisplayAlerts = False
Worksheets("Tabelle2").Delete
Worksheets("Tabelle3").Delete
Application.DisplayAlerts = True

NeueDatei.SaveAs Filename:=strDateiName, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Arbeitsblatt löschen
strTabelle = "Tabelle 1"

For i = 1 To Worksheets.Count
If Worksheets(i).Name = strTabelle Then
  Application.DisplayAlerts = False
  Worksheets(strTabelle).Delete
  Application.DisplayAlerts = True
  Exit For
End If
Next i

Prüfen, ob das Tabellenblatt vorhanden ist
Option Explicit

Sub TabelleVorhanden()
Dim strTabelle As String
Dim i As Integer

' Achtung: auf Groß- und Kleinschreibung achten
strTabelle = "Tabelle2"
For i = 1 To Worksheets.Count
If Worksheets(i).Name = strTabelle Then
MsgBox "Das Tabellenblatt existiert bereits."
End If
Next i
End Sub

Neues Tabellenblatt hinzufügen
Dim NeueTabelle As Worksheet

' Das Tabellenblatt darf nicht vorhanden sein.
Set NeueTabelle = Worksheets.Add(, Worksheets("Start"))' nach der Tabelle Start
NeueTabelle.Name = "Tabelle-neu"

Neues Tabellenblatt mit Datum und Zeit hinzufügen
Dim NeueTabelle As Worksheet

Set NeueTabelle = Worksheets.Add(, Worksheets("Start"))
Tabellenname = Year(Now)
If Month(Now) < 10 Then
Tabellenname = Tabellenname & "0"
End If
Tabellenname = Tabellenname & Month(Now)
If Day(Now) < 10 Then
Tabellenname = Tabellenname & "0"
End If
Tabellenname = Tabellenname & Day(Now)
Tabellenname = Tabellenname & "-"
If Hour(Now) < 10 Then
Tabellenname = Tabellenname & "0"
End If
Tabellenname = Tabellenname & Hour(Now)
If Minute(Now) < 10 Then
Tabellenname = Tabellenname & "0"
End If
Tabellenname = Tabellenname & Minute(Now)
Tabellenname = Tabellenname & "-"
If Second(Now) < 10 Then
Tabellenname = Tabellenname & "0"
End If
Tabellenname = Tabellenname & Second(Now)
Tabellenname = "Summe-" & Tabellenname' Summe-jjjjmmdd-hhmm-ss

NeueTabelle.Name = Tabellenname

Tabellenblatt kopieren
Sheets("Original").Copy After:=Sheets(1)
Sheets("Original (2)").Select
Sheets("Original (2)").Name = "Kopie"

Tabellenblatt aus- und einblenden
' Die Tabelle kann nur per VBA wieder eingeblendet werden.
Private Sub cmdOK_Click()

If Sheets("Temp").Visible = True Then
Sheets("Temp").Visible = xlVeryHidden
Else
Sheets("Temp").Visible = True
End If

End Sub

Erste leere Zelle der Spalte A ermitteln
Dim Zelle As Range

Set Zelle = Range("A1")

Do While Not IsEmpty(Zelle)
Set Zelle = Zelle.Offset(1, 0)
Loop

Zelle.Select

Spalte der aktiven Zelle markieren
ActiveCell.EntireColumn.Select
Columns(Selection.Column).Select

Belegten Bereich markieren
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

ActiveSheet.UsedRange.Select

Belegten Bereich um die aktive Zelle ohne die Zeile 1 markieren
Set tbl = ActiveCell.CurrentRegion

tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, _
tbl.Columns.Count).Select

Zelle zwei Zeilen unter der letzten Zeile in der letzten Spalte auswählen
Set LetzteZelle = ActiveCell.SpecialCells(xlLastCell)

LetzteZeile = LetzteZelle.Row
LetzteSpalte = LetzteZelle.Column

LetzteZeile = LetzteZeile + 2

Cells(LetzteZeile, LetzteSpalte).Select
ActiveCell.Value = "SUMMEN:"

Letzte Zelle des benutzten Bereiches selektieren
' Der benutzte Bereich kann auch leere Zeilen und Spalten enthalten.
Cells(ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row,
ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column).Select

Leere Zeilen und Spalten am Ende des benutzten Bereiches löschen
Option Explicit

Sub LöschenUsedRange()
Dim LetzteZeile, LetzteSpalte As Long
Dim Zelle, Bereich As Range
Dim Leer As Integer

' leere Zeilen löschen
Leer = 0

Do While Leer = 0
LetzteZeile = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
LetzteSpalte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
Set Bereich = Range(Cells(LetzteZeile, 1), Cells(LetzteZeile, LetzteSpalte))
Bereich.Select

For Each Zelle In Selection
   If Zelle.Value <> "" Then' nicht mit IsEmpty(Zelle) prüfen
    Leer = 1
   End If
Next Zelle

If Leer = 0 Then
   Rows(Selection.Row).Delete
End If
Loop

' leere Spalten löschen
Leer = 0

Do While Leer = 0
LetzteZeile = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
LetzteSpalte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
Set Bereich = Range(Cells(1, LetzteSpalte), Cells(LetzteZeile, LetzteSpalte))
Bereich.Select

For Each Zelle In Selection
   If Zelle.Value <> "" Then' nicht mit IsEmpty(Zelle) prüfen
    Leer = 1
  End If
Next Zelle

If Leer = 0 Then
   Columns(Selection.Column).Delete
End If
Loop

LetzteZeile = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
LetzteSpalte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
Cells(LetzteZeile, LetzteSpalte).Select

MsgBox ("Ende")

End Sub

Leere Zeilen löschen
Dim LetzteZeile As Long

LetzteZeile = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

For i = LetzteZeile To 2 Step -1 ' Leere Zeilen immer von unten nach oben löschen.

If Cells(i, 2).Value = "" And Cells(i, 7).Value = "" Then ' wenn die Spalte B und die Spalte G leer sind
Rows(i).Delete
End If

Next i

Anzahl der Zeilen bzw. Spalten der Markierung ermitteln
Selection.Rows.Count
Selection.Columns.Count

Nicht nebeneinander liegende Bereiche markieren
Set r1 = Range("B3")
Set r2 = Range("C6")
Set meinMehrblockBereich = Union(r1, r2)
meinMehrblockBereich.Select

Eine Zeile vor der Zeile 1 einfügen
' für die Spalten-Überschriften
Range("A1").Select
Selection.EntireRow.Insert

Rows("1:1").Select
Selection.Insert Shift:=xlDown

Eine leere Spalte einfügen
Columns(5).Select
Selection.EntireColumn.Insert

Eine Spalte mit Übernahme der Formatierung einfügen
Columns("O:O").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Eine Spalte ausschneiden und an anderer Stelle einfügen
' die bestehenden Spalten werden nach rechts verschoben
Columns("E:E").Select
Selection.Cut
Columns("C:C").Select
Selection.Insert Shift:=xlToRight

Zellen der Markierung mit bisherigen Inhalt neu füllen
Option Explicit

Sub ReSchreiben()

Dim rngZelle As Range
Dim varInhalt As Variant

For Each rngZelle In Selection
varInhalt = rngZelle.FormulaLocal
rngZelle.FormulaLocal = varInhalt
Next

End Sub

Automatisches Ausfüllen eines Bereiches mit einer Formel oder Zahl
With ActiveSheet
.Range("c1").FormulaLocal = "=A1+B1"
.Range("c1:c10").FillDown
End With

Prüfen auf einen numerischen Wert in einer Zelle
If IsNumeric(Cells(3, 2).Value) Then
Summe = Summe + Cells(3, 2).Value
End If

Summe einfügen
Dim AnzahlJahre As Integer

AnzahlJahre = 5
ActiveCell.FormulaR1C1 = "=SUM(RC[-" & AnzahlJahre & "]:RC[-1])"

Sub SummeSpalteA()
Dim Zeile As Long
Zeile = Cells(Rows.Count, 1).End(xlUp).Row
Cells(Zeile + 1, 1).Formula = "=Sum(A1:A" & Zeile & ")"
End Sub

dblSumme = WorksheetFunction.Sum(Range("A1:A20"))

.FormulaR1C1 = "=RC[-5]+RC[-3]+RC[-1]"

Durchschnitt
Range("B1").Formula = "=AVERAGE(A1:A20)"

Ergebnis auf zwei Nachkommastellen runden
ActiveCell.FormulaR1C1 = "=ROUND( RC[-2] * RC[-1] ,2)"

D-Mark in Euro umrechnen
' Das Euro-Währungstool aktivieren: Menü Datei, Optionen, Add-Ins
ActiveCell.FormulaR1C1 = "=EUROCONVERT(RC[-1],""DEM"",""EUR"",FALSE)"

Zeile kopieren
Rows(9).Select
Selection.Copy
' Sheets("Speicher").Select ' wenn in ein anderes Tabellenblatt kopieren
Rows(13).Select
ActiveSheet.Paste' Überschreiben
Application.CutCopyMode = False' den Kopier-Modus ausschalten (kein Blinken)

Spalte linksbündig ausrichten
Columns("B:B").Select
Selection.HorizontalAlignment = xlLeft' oder xlCenter bzw. xlRight

Schrift im Bereich fett formatieren
ActiveSheet.Range("A1:F1").Font.Bold = True

Werte in Spalten bzw. in einem Bereich formatieren
Range("Y1:Z1").Select
Selection.NumberFormat = "General"' im Standard-Format

Columns("A:B").Select
Selection.NumberFormat = "@"' als Text

Columns("G:G").Select
Selection.NumberFormat = "0.00"' mit 2 Nachkommastellen

Columns("I:L").Select
Selection.NumberFormat = "#,##0"' mit dem Punkt als Tausender-Trennzeichen

Columns(6).Select
Selection.NumberFormat = "00000"' für deutsche PLZ

Columns("M:N").Select
Selection.NumberFormat = "m/d/yyyy"' als Datum

Worksheets("Tabelle1").Columns(5).NumberFormat = "hh:mm:ss"
Worksheets("Tabelle1").Columns(6).NumberFormat = "mmmm yyyy;@"

Auto-Filter
Sub GasAnzeigen()
' nur die Zeilen mit dem Begriff "Gas" im Bereich B8 bis B11 anzeigen
ActiveSheet.Range("$B$8:$B$11").AutoFilter Field:=1, Criteria1:="Gas"
ActiveSheet.Range("$C$13").Select
End Sub

Sub AllesAnzeigen()
' Auto-Filter wieder deaktivieren
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
ActiveSheet.Range("$C$13").Select
End If
End Sub

Teilergebnisse erzeugen
Worksheets("Summe").Activate
Columns("A:E").Select

Selection.Subtotal GroupBy:=4, Function:=xlSum, TotalList:=Array(2, 5), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True

Teilergebnisse wieder entfernen
Columns("A:E").Select

On Error Resume Next
Selection.RemoveSubtotal
On Error GoTo 0

Tabellenblatt nach drei Spalten sortieren
ActiveSheet.Select
Range("A1").Activate

Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("A2"), _
Order2:=xlAscending, Key3:=Range("L2"), Order3:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers, DataOption2:=xlSortTextAsNumbers, _
DataOption3:=xlSortTextAsNumbers

Tabellenblatt mit Spalten-Überschriften nach markierter Zelle sortieren
Spalte = Selection.Column

Cells.Select

Selection.Sort Key1:=Cells(2, Spalte), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Cells(2, Spalte).Select

Tabellenblatt mit Adressen nach Land und PLZ sortieren
Option Explicit

Sub SortLandPLZ()
' Die Spalten Land und PLZ können an beliebiger Position stehen.
' Bitte eine Zelle in der Spalte Land markieren.
Dim Zelle As Range
Dim Zaehler As Integer
Dim SpalteLand As Long
Dim SpaltePLZ As Long

' aktuelle Zelle in der Spalte Land
SpalteLand = Selection.Column
Zaehler = 0

' die Spalte PLZ suchen, diese sollte nur einmal vorhanden sein
Rows("1:1").Select

For Each Zelle In Selection

If StrConv(Zelle.Value, vbUpperCase) Like "PLZ*" Then
   SpaltePLZ = Zelle.Column ' die letzte Spalte mit PLZ in der Überschrift
   Columns(SpaltePLZ).Select
   Selection.NumberFormat = "@"' als Text formatieren
   Zaehler = Zaehler + 1
End If

Next Zelle

' Sortieren der Tabelle, wenn es eine Spalte PLZ gibt
If Zaehler = 0 Then
Cells(2, SpalteLand).Select
Else
Cells.Select ' Alle Zellen der Tabelle markieren

' Sortieren der Tabelle nach Land und PLZ
Selection.Sort Key1:=Cells(2, SpalteLand), Order1:=xlAscending, _
   Key2:=Cells(2, SpaltePLZ), Order2:=xlAscending, _
   Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
   DataOption1:=xlSortTextAsNumbers, DataOption2:=xlSortTextAsNumbers

Cells(2, SpaltePLZ).Select ' die Zelle 2 der Spalte PLZ zur Kontrolle markieren
End If

If Zaehler > 1 Then
MsgBox ("Die Spalte PLZ ist " & Str(Zaehler) & "mal vorhanden.")
End If

End Sub

Die deutsche PLZ mit einer Vornull versehen (9123 -> 09123)
Option Explicit

Sub PLZVornullMarkierung()
' die PLZ-Spalte als Text formatieren, aufsteigend sortieren und
' den vierstelligen Bereich der PLZ-Spalte markieren
Dim Zelle As Range
Dim strWert As String

For Each Zelle In Selection
strWert = Zelle.Value
Zelle.FormulaR1C1 = "'0" & strWert
Next Zelle

End Sub

Die deutsche PLZ mit einer Vornull versehen (Variante 2)
Option Explicit

Sub PLZVornullSpalte()
' Eine Zelle in der Spalte PLZ markieren
' Achtung bei Österreich
Dim Zelle As Range
Dim strWert As String

Columns(Selection.Column).Select
Selection.NumberFormat = "@"' als Text formatieren

Set Zelle = Cells(2, Selection.Column)
Do While Not IsEmpty(Zelle)
strWert = Zelle.Value

If Len(strWert) = 4 Then
Zelle.Value = "'0" & strWert
End If

Set Zelle = Zelle.Offset(1, 0)
Loop

Cells(1, Selection.Column).Select

MsgBox ("Ende")

End Sub

Das Land und die PLZ (A-1234) in zwei Spalten separieren
Option Explicit

Sub PLZTrennen()
Dim strText As String
Dim strLand As String
Dim strPLZ As String
Dim Zelle As Range
Dim Zaehler As Integer
Dim SpaltePLZ As Long
Dim SpalteLand As Long

' die Spalte PLZ suchen, diese sollte nur einmal vorhanden sein
Zaehler = 0
Rows("1:1").Select

For Each Zelle In Selection

If StrConv(Zelle.Value, vbUpperCase) Like "PLZ*" Then
  SpaltePLZ = Zelle.Column' die letzte Spalte mit PLZ in der Überschrift
  Zaehler = Zaehler + 1
End If

Next Zelle

If Zaehler > 1 Then
MsgBox ("Die Spalte PLZ ist " & Str(Zaehler) & "mal vorhanden.")
Exit Sub
End If

' eine Spalte einfügen für die PLZ
Columns(SpaltePLZ + 1).Select
Selection.EntireColumn.Insert
Selection.NumberFormat = "@"' als Text formatieren

' die Spalte Land suchen, diese sollte nur einmal vorhanden sein
Zaehler = 0
Rows("1:1").Select

For Each Zelle In Selection

If StrConv(Zelle.Value, vbUpperCase) Like "LAND*" Then
  SpalteLand = Zelle.Column' die letzte Spalte mit Land in der Überschrift
  Zaehler = Zaehler + 1
End If

Next Zelle

If Zaehler > 1 Then
MsgBox ("Die Spalte Land ist " & Str(Zaehler) & "mal vorhanden.")
Exit Sub
End If

' Wenn es bereits eine Spalte Land gibt, diese ausschneiden und einfügen.
' Sonst noch eine leere Spalte für das Land einfügen
If Zaehler = 1 Then
If (SpaltePLZ + 2) <> SpalteLand Then' nur dann einfügen
  Columns(SpalteLand).Select
  Selection.Cut
  Columns(SpaltePLZ + 2).Select
  Selection.Insert Shift:=xlToRight
End If
Else
Columns(SpaltePLZ + 1).Select
Selection.EntireColumn.Insert
Selection.NumberFormat = "@"' als Text formatieren
End If

' die Spalte PLZ erneut suchen
Zaehler = 0
Rows("1:1").Select

For Each Zelle In Selection

If StrConv(Zelle.Value, vbUpperCase) Like "PLZ*" Then
  SpaltePLZ = Zelle.Column' die letzte Spalte mit PLZ in der Überschrift
  Zaehler = Zaehler + 1
End If

Next Zelle

' Überschriften
Cells(1, SpaltePLZ).Value = "PLZ-alt"
Cells(1, SpaltePLZ + 1).Value = "PLZ"
Cells(1, SpaltePLZ + 2).Value = "Land"

' Trennen
Set Zelle = Cells(2, SpaltePLZ)

Do While Not IsEmpty(Zelle)

strText = Zelle.Value' Text aus der aktiven Zelle

If InStr(strText, "-") <> 0 Then' mit Bindestrich
  strLand = Left(strText, InStr(strText, "-") - 1)
  strPLZ = Right(strText, Len(strText) - (InStr(strText, "-")))

  Set Zelle = Zelle.Offset(0, 1)
  Zelle.Value = strPLZ

  Set Zelle = Zelle.Offset(0, 1)
  Zelle.Value = strLand

  Set Zelle = Zelle.Offset(1, -2)
Else
  Set Zelle = Zelle.Offset(0, 1)
  Zelle.Value = strText

  Set Zelle = Zelle.Offset(1, -1)
End If

Loop

Cells(2, SpaltePLZ).Select

ActiveSheet.Columns.AutoFit

End Sub

Bedingte Formatierung
' Werte größer 90000 in der Markierung mit hellroten Hintergrund versehen
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
Formula1:="=90000"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With

Selection.FormatConditions(1).StopIfTrue = False

Bedingte Formatierung im gesamten Arbeitsblatt löschen
Cells.FormatConditions.Delete

Zeilen mit gleichen Werten in einer Spalte in ein neues Blatt kopieren
' mit bedingter Formatierung
' Tabelle: Lieferscheine, Lieferschein-Nummern in der Spalte C
Option Explicit

Sub LSMehrfach()
Dim NeueTabelle As Worksheet
Dim strTabelle As String
Dim i As Integer

strTabelle = "Lieferscheine-Mehrfach"
For i = 1 To Worksheets.Count
If Worksheets(i).Name = strTabelle Then
  Application.DisplayAlerts = False
  Worksheets(strTabelle).Delete
  Application.DisplayAlerts = True
End If
Next i

Set NeueTabelle = ActiveWorkbook.Worksheets.Add(, Worksheets("Lieferscheine"))
NeueTabelle.Name = "Lieferscheine-Mehrfach"

Sheets("Lieferscheine").Select
Columns("C:C").Select

Selection.FormatConditions.AddUniqueValues ' Duplikate auswählen
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate

With Selection.FormatConditions(1).Interior ' mehrfache Werte einfärben
   .Color = RGB(255, 199, 206)
End With

Selection.AutoFilter

ActiveSheet.Range("C:C").AutoFilter Field:=1, Criteria1:=RGB(255, 199, 206), _
Operator:=xlFilterCellColor

Cells.Select
Selection.Copy

Sheets("Lieferscheine-Mehrfach").Select
ActiveSheet.Paste

Sheets("Lieferscheine").Select
ActiveSheet.ShowAllData

End Sub

Farb-Indizes von Excel in ein neues Blatt einfügen
Option Explicit

Sub FarbwerteAuslesen()
Dim i As Integer

Sheets.Add

For i = 1 To 56' größer gibt einen Fehler
Cells(i, 1).Interior.ColorIndex = i
Cells(i, 2).Value = i
Next i

End Sub

Farb-Indizes mit Hex- und RBG-Werten in ein Blatt einfügen
Sub Liste()
Dim Zelle, ZelleAlt As Range

Columns("A:D").Select
Selection.ClearContents
Selection.HorizontalAlignment = xlCenter
Columns("B:B").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Columns("D:D").Select
Selection.NumberFormat = "@"

Set Zelle = Cells(1, 1)
Zelle.Value = "Index"
Set Zelle = Cells(1, 2)
Zelle.Value = "Farbe"
Set Zelle = Cells(1, 3)
Zelle.Value = "Hex"
Set Zelle = Cells(1, 4) Zelle.Value = "RBG"

Rows("1:1").Select
Selection.Font.Bold = True

Set Zelle = Cells(2, 1)

For i = 1 To 56' größer gibt einen Fehler
Zelle.Value = i
Set Zelle = Zelle.Offset(0, 1)

Zelle.Interior.ColorIndex = i
Set ZelleAlt = Zelle

Set Zelle = Zelle.Offset(0, 1)
Zelle.Value = HexWerte(ZelleAlt.Interior.Color)

Set Zelle = Zelle.Offset(0, 1)
Zelle.Value = RGBWerte(ZelleAlt.Interior.Color)

Set Zelle = Zelle.Offset(1, -3)
Next i

Columns("D:D").AutoFit
Cells(1, 1).Select
End Sub

Public Function HexWerte(zahl As Long) As String
' Basis: 2 binär, 8 oktal, 16 hexadezimal
Dim basis As Integer: basis = 16
Dim h: h = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, "a", "b", "c", "d", "e", "f")
Dim mask As Long: mask = 1

Do
mask = zahl Mod basis
zahl = Int(zahl / basis)
HexWerte = h(mask) & HexWerte
Loop Until zahl < 1

' 6-stellig für HTML-Farbcodes
While Len(HexWerte) < 6
HexWerte = "0" + HexWerte
Wend

' Rot und Blau tauschen
HexWerte = Right$(HexWerte, 2) + Mid$(HexWerte, 3, 2) + Left$(HexWerte, 2)
End Function

Public Function RGBWerte(farbe As Long) As String
Dim r As Integer
Dim g As Integer
Dim b As Integer

For r = 0 To 255
For g = 0 To 255
  For b = 0 To 255
    If RGB(r, g, b) = farbe Then
     RGBWerte = r & ", " & g & ", " & b
     Exit Function
    End If
  Next
Next
Next
End Function

Function FarbeErmitteln(FarbIndex As Integer)
' Übergabe vom Zelle.Interior.ColorIndex oder Zelle.Font.ColorIndex
Select Case FarbIndex
Case 1
  strFarbe = "#000000"
Case 0, 2
  strFarbe = "#ffffff"
Case 3
  strFarbe = "#ff0000"
Case 4
  strFarbe = "#00ff00"
Case 5, 32
  strFarbe = "#0000ff"
Case 6, 27
  strFarbe = "#ffff00"
Case 7, 26
  strFarbe = "#ff00ff"
Case 8, 28
  strFarbe = "#66ccff"'Farbcode geändert Standard: 00ffff
Case 9, 30
  strFarbe = "#800000"
Case 10
  strFarbe = "#008000"
Case 11, 25
  strFarbe = "#000080"
Case 12
  strFarbe = "#808000"
Case 13, 29
  strFarbe = "#800080"
Case 14
  strFarbe = "#008080"
Case 15
  strFarbe = "#c0c0c0"
Case 16
  strFarbe = "#808080"
Case 17
  strFarbe = "#9999ff"
Case 18
  strFarbe = "#993366"
Case 19
  strFarbe = "#ffffcc"
Case 20, 34
  strFarbe = "#ccffff"
Case 21
  strFarbe = "#660066"
Case 22
  strFarbe = "#ff8080"
Case 23
  strFarbe = "#0066cc"
Case 24
  strFarbe = "#ccccff"
Case 31
  strFarbe = "#008080"
Case 33
  strFarbe = "#00ccff"
Case 35
  strFarbe = "#ccffcc"
Case 36
  strFarbe = "#ffff99"
Case 37
  strFarbe = "#99ccff"
Case 38
  strFarbe = "#ff99cc"
Case 39
  strFarbe = "#cc99ff"
Case 40
  strFarbe = "#ffcc99"
Case 41
  strFarbe = "#3366ff"
Case 42
  strFarbe = "#33cccc"
Case 43
  strFarbe = "#99cc00"
Case 44
  strFarbe = "#ffcc00"
Case 45
  strFarbe = "#ff9900"
Case 46
  strFarbe = "#ff6600"
Case 47
  strFarbe = "#666699"
Case 48
  strFarbe = "#969696"
Case 49
  strFarbe = "#003366"
Case 50
  strFarbe = "#339966"
Case 51
  strFarbe = "#003300"
Case 52
  strFarbe = "#333300"
Case 53
  strFarbe = "#993300"
Case 54
  strFarbe = "#993366"
Case 55
  strFarbe = "#333399"
Case 56
  strFarbe = "#333333"

Case Else
  MsgBox "Bitte Farben prüfen."
  strFarbe = "gray"
End Select

End Function

Jede zweite Zeile der Markierung gelb einfärben
Option Explicit

Sub ZellFärben()
Dim Zeile As Range
Dim ZeilenNr As Long

ZeilenNr = 0

For Each Zeile In Selection.Rows
ZeilenNr = ZeilenNr + 1

If ZeilenNr Mod 2 = 0 Then
Zeile.Interior.ColorIndex = 6
Else
Zeile.Interior.ColorIndex = xlAutomatic
End If

Zeile.Borders.Weight = xlThin' mit einem dünnen Rahmen
Next

End Sub

Hexadezimale bzw. RGB-Werte der Farben der Zelle B2 ermitteln
' die Zellen D2, D3, F2, F3 als Text formatieren
Range("D2").Value = HexWerte(Range("B2").Interior.Color)
Range("D3").Value = HexWerte(Range("B2").Font.Color)

Range("F2").Value = RGBWerte(Range("B2").Interior.Color)
Range("F3").Value = RGBWerte(Range("B2").Font.Color)

Public Function HexWerte(zahl As Long) As String
' Basis: 2 binär, 8 oktal, 16 hexadezimal

Dim basis As Integer: basis = 16
Dim h: h = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, "A", "B", "C", "D", "E", "F")
Dim mask As Long: mask = 1

Do
mask = zahl Mod basis
zahl = Int(zahl / basis)
HexWerte = h(mask) & HexWerte
Loop Until zahl < 1

' 6-stellig für HTML-Farbcodes
While Len(HexWerte) < 6
HexWerte = "0" + HexWerte
Wend

' Rot und Blau tauschen
HexWerte = Right$(HexWerte, 2) + Mid$(HexWerte, 3, 2) + Left$(HexWerte, 2)

End Function

Public Function RGBWerte(farbe As Long) As String

Dim r As Integer
Dim g As Integer
Dim b As Integer

For r = 0 To 255
For g = 0 To 255
  For b = 0 To 255
    If RGB(r, g, b) = farbe Then
    RGBWerte = r & "," & g & "," & b
    Exit Function
    End If
  Next
Next
Next

End Function

Spalte und Reihe der aktuellen Zelle einfärben
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Application.EnableEvents = False

Cells.Interior.ColorIndex = xlColorIndexNone
Target.EntireColumn.Interior.ColorIndex = 4' grelles Grün
Target.EntireRow.Interior.ColorIndex = 4
Target.Interior.ColorIndex = 6' gelb
Target.Activate
Application.EnableEvents = True

End Sub

Datum definieren
Dim datDatum As Date
datDatum = #12/23/1992#' mmddyyyy

Datum und Zeit einfügen
ActiveSheet.Cells(1, 1) = Format(Date, "dd. MMMM YYYY")

Selection.InsertDateTime DateTimeFormat:="dd.MM.yyyy HH:mm", InsertAsField _
:=False, DateLanguage:=wdGerman, CalendarType:=wdCalendarWestern, _
InsertAsFullWidth:=False

Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"TIME \@ ""HH:mm"" ", PreserveFormatting:=True

Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"DATE ", PreserveFormatting:=True

Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldDate, PreserveFormatting:=True

Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldTime, PreserveFormatting:=True

Anzahl der Tage seit einem bestimmten Datum ermitteln
Dim datStart As Date
Dim AnzahlTage As Integer

datStart = "01.01.2001"
AnzahlTage = DateDiff("d", datStart, Now)

Anzahl der Tage des Monats aus dem Datum der Zelle A2 ermitteln
Monat = Month(Range("A2").Value)
Jahr = Year(Range("A2").Value)
intAnzTage = Day(DateSerial(Year:=Jahr, Month:=Monat + 1, Day:=0))
Range("B2").Value = intAnzTage

Letzten Tag des Vormonats ermitteln
Dim datDatum As Date

datDatum = Date' heute

' erster Tag des aktuellen Monats - 1
datDatum = DateSerial(Year(datDatum), Month(datDatum), 1 - 1)

Vormonat in die aktive Zelle einfügen
Dim LetzterMonat As Date

LetzterMonat = DateSerial(Year(Now), (Month(Now) - 1), Day(Now))
ActiveCell.FormulaR1C1 = LetzterMonat
Selection.NumberFormat = "mmmm yyyy;@"

Den Tag aus einer Datumsspalte abschneiden
Option Explicit

Sub DatumZerlegen()
Option Explicit

Dim Zelle As Range
Dim strWert As String

' neue Spalte F als Text formatieren, erhält MM.YYYY
Columns(6).Select
Selection.NumberFormat = "@"' als Text

' alte Spalte E mit TT.MM.YYYY
Set Zelle = Cells(2, 5)

Do While Not IsEmpty(Zelle)
' siehe auch Day-, Month- und Year-Funktion
strWert = Right(Zelle.Value, 7)

Set Zelle = Zelle.Offset(0, 1)
Zelle.Value = strWert

Set Zelle = Zelle.Offset(1, -1)
Loop

MsgBox ("Ende")

End Sub

Datum aus einer Textbox in das Datums-Format umwandeln
Tabelle1.Cells(7, 2).Value = CDate(txtStart.Text)

Preis aus einer Textbox in das Währungs-Format konvertieren
Tabelle1.Cells(7, 3).style = "Currency"
Tabelle1.Cells(7, 3).Value = CCur(txtPreis.Text)

Zahl in eine Zeichenkette konvertieren
strWert = CStr(Tabelle1.Cells(7, 3).Value)

Funktionen zum Konvertieren in eine Zahl
CDbl, CDec, CInt, CLng, CLngLng, CLngPtr, CSng

Booleschen Wert ermitteln
Dim intA, intB As Integer
Dim bolCheck As Boolean

intA = 5
intB = 5
bolCheck = CBool(intA = intB)' ergibt wahr

intA = 0
bolCheck = CBool(intA = intB)' ergibt falsch

Zeichenkette in Großbuchstaben umwandeln
ActiveCell.Value = StrConv(ActiveCell.Value, vbUpperCase)

Zeichen ersetzen
Columns("D:D").Select

' Alle Bindestriche werden aus der Zeichenkette entfernt.
Selection.Replace "-", ""

Mehrfache Leerzeichen in Zeichenketten entfernen
Option Explicit

Sub Trimmen()

Dim Zelle As Range

For Each Zelle In Selection
Zelle.Value = WorksheetFunction.Trim(Zelle.Value)
Next Zelle

End Sub

Dim strName As String
' 2 Leerzeichen, 3 Buchstaben, 5 Leerzeichen, 3 Buchstaben, 2 Leerzeichen
strName = " abc dfe "

' Ausgabe der kompletten Zeichenkette
MsgBox strName' Länge: 15 Zeichen

' VBA-Trim: Am Anfang und Ende werden die vorhandenen Leerzeichen entfernt.
MsgBox Trim(strName)' Länge: 11 Zeichen

' Excel-VBA-Trim: Zusätzlich bleibt in der Mitte nur ein Leerzeichen erhalten.
MsgBox WorksheetFunction.Trim(strName)' Länge: 7 Zeichen

Werte in kompletter Zelle ersetzen
Columns("D:D").Select

Selection.Replace What:="Alt", Replacement:="Neu", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Zeilenumbrüche durch ein Leerzeichen in allen Zellen der Tabelle ersetzen
Dim Zelle As Range

For Each Zelle In ActiveSheet.UsedRange.Cells
Zelle.Value = WorksheetFunction.Substitute(Zelle.Value, vbLf, " ")
Next Zelle

Inhalte und Formatierungen in einem Bereich löschen
ActiveSheet.Range("A2:F1000").Clear

Inhalte in einem Bereich löschen
ActiveSheet.Range("A2:F1000").ClearContents

Verstecken der Spalten L und M
Columns("L:M").Select
Selection.EntireColumn.Hidden = True

Spalte löschen
Columns("L:L").Select
Selection.Delete Shift:=xlToLeft

Zeile löschen
Rows(5).Select
Selection.Delete Shift:=xlUp

Spalte bzw. Zeile der aktuellen Zelle löschen
ActiveCell.EntireColumn.Delete
ActiveCell.EntireRow.Delete

Löschen eines Tabellenblatts ohne Nachfrage
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Tabelle-alt").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Diagramm erstellen
Dim NeueTabelle As Worksheet
Dim NeuesDiagramm As Chart

' Löschen der Tabellen ohne Nachfrage
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Daten").Delete
Charts("Diagramm").Delete
Worksheets("Daten2").Delete
Application.DisplayAlerts = True
On Error GoTo 0

' Die Tabelle Start enthält nur den Button mit einer Verknüpfung zu diesem Makro.
Set NeueTabelle = ActiveWorkbook.Worksheets.Add(, Worksheets("Start"))
NeueTabelle.Name = "Daten"

' Importieren der Textdatei Import.csv (im Pfad der Excel-Mappe) mit dem Inhalt:
Datum;B-Wert;
01.01.2010;120€;
02.01.2010;80€;
03.01.2010;100€;
04.01.2010;40€;

With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & ThisWorkbook.Path & "\Import.csv", _
Destination:=Range("A1"))
  .Name = "Import_1"
  .FieldNames = True
  .RowNumbers = False
  .FillAdjacentFormulas = False
  .PreserveFormatting = True
  .RefreshOnFileOpen = False
  .RefreshStyle = xlInsertDeleteCells
  .SavePassword = False
  .SaveData = True
  .AdjustColumnWidth = True
  .RefreshPeriod = 0
  .TextFilePromptOnRefresh = False
  .TextFilePlatform = 1252
  .TextFileStartRow = 1
  .TextFileParseType = xlDelimited
  .TextFileTextQualifier = xlTextQualifierDoubleQuote
  .TextFileConsecutiveDelimiter = False
  .TextFileTabDelimiter = False
  .TextFileSemicolonDelimiter = True
  .TextFileCommaDelimiter = False
  .TextFileSpaceDelimiter = False
  .TextFileColumnDataTypes = Array(4, 1, 1)
  .TextFileTrailingMinusNumbers = True
  .Refresh BackgroundQuery:=False
End With

' Erstellen eines separaten Linien-Diagramms aus den Spalte A und B der Tabelle Daten
Set NeuesDiagramm = ActiveWorkbook.Charts.Add
NeuesDiagramm.Name = "Diagramm"
NeuesDiagramm.Move After:=Sheets(3)

With ActiveChart
.ChartType = xlLine
.SetSourceData Source:=Sheets("Daten").Range("A:A,B:B"), PlotBy:=xlColumns
End With

' Einfügen einer Trendlinie
ActiveChart.SeriesCollection(1).Trendlines.Add(Type:=xlPolynomial, Order:=2, DisplayEquation:=False, _
DisplayRSquared:=False, Name:="Trend").Select

' Erstellen einer Tabelle mit einem integrierten Diagramm
Sheets("Daten").Copy After:=Sheets(3)
Sheets("Daten (2)").Name = "Daten2"

ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Sheets("Daten2").Range("A:A,B:B")
ActiveChart.ChartType = xlArea

Zufallszahlen von 1 bis 49 in die Spalte A und Rang von Spalte A in Spalte C einfügen
Dim IntZelle As Range
Dim Wert1, Untergrenze, Obergrenze

Untergrenze = 1
Obergrenze = 49

Columns("A:C").ClearContents
Range("A1").Value = "Wert"
Range("C1").Value = "Rang"

Set IntZelle = Range("A2")

For i = 1 To 32000
Randomize ' den Zufallszahlengenerator initialisieren
IntZelle.FormulaR1C1 = Int((Obergrenze - Untergrenze + 1) * Rnd + Untergrenze)
Set IntZelle = IntZelle.Offset(1, 0)
Next i

Set IntZelle = Range("A2")

Do While Not IsEmpty(IntZelle)
Set IntZelle = IntZelle.Offset(0, 2)
IntZelle.FormulaR1C1 = "=RANK(RC[-2],C[-2])"
Set IntZelle = IntZelle.Offset(1, -2)
Loop

E-Mail im HTML-Format mit Signatur und Excel-Arbeitsmappe in der Anlage erstellen
Option Explicit

Sub MailSendenHTML()

Dim objOutlook As Object
Dim strAnlage As String, olOldBody As String, strDatum As String

strDatum = Sheets("Tabelle1").Range("B2")' Die Zelle enthält das Datum.

strAnlage = ActiveWorkbook.Path & "\" & "Bestellung zum Auftrag am " & strDatum & _
Mid(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, "."))

ActiveWorkbook.SaveCopyAs strAnlage' die Anlage als Kopie speichern

Set objOutlook = CreateObject("Outlook.Application")
With objOutlook.CreateItem(0)
.GetInspector.Display' die Signatur einfügen

olOldBody = .htmlBody' Zwischenspeichern vom Body mit der Signatur

.To = "mail@didier-cuche.ch"

.Subject = "Bestellung zum Auftrag am " & strName

.htmlBody = "Sehr geehrte Damen und Herren,<br><br>" & _
"anbei Bestellbestätigung zum Auftrag am " & strDatum & _
olOldBody' die zwischengespeicherte Signatur einfügen

.Attachments.Add strAnlage ' die Anlage einfügen
End With

Kill strAnlage' Löschen der Anlage

Set objOutlook = Nothing

End Sub

Plattenplatz-Auslastung für lokale und Netzwerk-Laufwerke
Option Explicit

Sub Laufwerke()

Dim WshNet As Object
Dim fs, d, dc As Object
Dim Reihe, Total, Frei, Prozent As Variant
Dim Rechnername, DriveName, strTyp As String
Dim Tabellenname As String
Dim NeueTabelle As Worksheet

' Rechnername ermitteln
Set WshNet = CreateObject("WScript.Network")
Rechnername = WshNet.Computername

Set fs = CreateObject("Scripting.FileSystemObject", Rechnername)
Set dc = fs.Drives

' Neues Tabellenblatt mit Datum und Zeit
Set NeueTabelle = Worksheets.Add(, Worksheets("Start"))
Tabellenname = Year(Now)
If Month(Now) < 10 Then
Tabellenname = Tabellenname & "0"
End If
Tabellenname = Tabellenname & Month(Now)
If Day(Now) < 10 Then
Tabellenname = Tabellenname & "0"
End If
Tabellenname = Tabellenname & Day(Now)
Tabellenname = Tabellenname & "-"
If Hour(Now) < 10 Then
Tabellenname = Tabellenname & "0"
End If
Tabellenname = Tabellenname & Hour(Now)
If Minute(Now) < 10 Then
Tabellenname = Tabellenname & "0"
End If
Tabellenname = Tabellenname & Minute(Now)
Tabellenname = Tabellenname & "-"
If Second(Now) < 10 Then
Tabellenname = Tabellenname & "0"
End If
Tabellenname = Tabellenname & Second(Now)
NeueTabelle.Name = Tabellenname

' Überschrift
Reihe = 1
Cells(Reihe, 1).Value = "Computer"
Cells(Reihe, 2).Value = "Letter"
Cells(Reihe, 3).Value = "Typ"
Cells(Reihe, 4).Value = "Name"
Cells(Reihe, 5).Value = "Total (kB)"
Cells(Reihe, 6).Value = "Belegt (kB)"
Cells(Reihe, 7).Value = "Frei (kB)"
Cells(Reihe, 8).Value = "Frei (%)"

Cells(2, 1).Value = Rechnername

' Laufwerke
For Each d In dc
Reihe = Reihe + 1

Cells(Reihe, 2).Value = d.DriveLetter

Select Case d.DriveType
  Case 0: strTyp = "Unbekannt"
  Case 1: strTyp = "Wechsellaufwerk"
  Case 2: strTyp = "Festplatte"
  Case 3: strTyp = "Netzlaufwerk"
  Case 4: strTyp = "CD-ROM"
  Case 5: strTyp = "RAM Disk"
End Select

Cells(Reihe, 3).Value = strTyp

If d.IsReady Then
  If d.DriveType = 3 Then
    DriveName = d.ShareName
  Else
    DriveName = d.VolumeName
  End If

  Cells(Reihe, 4).Value = DriveName

  Total = Round(d.TotalSize / 1024, 3)' in kB
  Cells(Reihe, 5).Value = Total

  Frei = Round(d.FreeSpace / 1024, 3)' in kB
  Cells(Reihe, 7).Value = Frei

  Prozent = Round(Frei / Total * 100, 2)
  Cells(Reihe, 8).Value = Prozent

  Cells(Reihe, 6).Value = Total - Frei
Else
  Cells(Reihe, 4).Value = "Das Laufwerk ist nicht bereit!"
End If
Next

' Formatieren der Seite
Rows("1:1").Select
With Selection
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With

Columns("B:B").Select
Selection.HorizontalAlignment = xlCenter

Columns("E:G").Select
Selection.NumberFormat = "#,##0"
Columns("H:H").Select
Selection.NumberFormat = "0.00"
Columns("A:H").Select
Selection.Columns.AutoFit

With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
.PrintArea = ""
.LeftHeader = "Plattenplatz"
.CenterHeader = "&A"
.RightHeader = "&D &T"
.PrintHeadings = False
.PrintGridlines = True
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlPortrait
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

Range("A3").Select

Set WshNet = Nothing
Set fs = Nothing
Set d = Nothing
Set dc = Nothing

MsgBox ("Ende")

End Sub

Text in mehrere Spalten aufteilen
' Die Original-Spalte nach Spalte C kopieren.
' Die Spalten ab D sollten leer sein.
' Das Trennzeichen ist hier das Semikolon.
Columns("C:C").TextToColumns DataType:=xlDelimited, Semicolon:=True

Text-Datei öffnen
Workbooks.OpenText Filename:="LW:\Pfad\Datei.txt", Origin:=xlWindows, _' oder Origin:=xlMSDOS
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, Other:=True, OtherChar:="|", DecimalSeparator:=".", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), _
Array(7, 1), Array(8, 5), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), _
Array(14, 1)), TrailingMinusNumbers:=True

Daten aus einer Text-Datei importieren
With ActiveSheet.QueryTables.Add(Connection:=TEXT; _
"LW:\Pfad\Import.txt", Destination:=Range("$A$3"))
  .Name = "Import-Daten"
  .FieldNames = True ' mit den Feldnamen in der ersten Zeile
  .RowNumbers = False
  .FillAdjacentFormulas = False
  .PreserveFormatting = True
  .RefreshOnFileOpen = False
  .RefreshStyle = xlInsertDeleteCells
  .SavePassword = False
  .SaveData = True
  .AdjustColumnWidth = True
  .RefreshPeriod = 0
  .TextFilePromptOnRefresh = False
  .TextFilePlatform = 1252
  .TextFileStartRow = 1
  .TextFileParseType = xlDelimited
  .TextFileTextQualifier = xlTextQualifierDoubleQuote
  .TextFileDecimalSeparator = "."
  .TextFileConsecutiveDelimiter = False
  .TextFileTabDelimiter = False
  .TextFileSemicolonDelimiter = False
  .TextFileCommaDelimiter = False
  .TextFileSpaceDelimiter = False
  .TextFileOtherDelimiter = "|" ' das Feld-Trennzeichen ist Pipe
   .TextFileColumnDataTypes = Array(1, 1, 2, 2, 1, 2, 1, 5, 2, 5, 1) ' die Feld-Definitionen anpassen
  .TextFileTrailingMinusNumbers = True
  .Refresh BackgroundQuery:=False
End With

Daten aus MS Access mit SQL direkt importieren
Dim strDBOpen, strSQL As String
Dim datAnfang, datEnde As Date

datAnfang = Range("$B$7").Value' die Zelle enthält ein Datum
datEnde = Range("$D$7").Value' die Zelle enthält ein Datum

strDBOpen = "ODBC;DBQ=LW:\Access\Archiv.mdb;DefaultDir=Lw:\Access\; _
Driver={Driver do Microsoft Access (*.mdb)};DriverId=281;FIL=MS Access;"

' Datumsformat für die SQL-Abfrage: #m/t/jjjj#
strSQL = "SELECT Datum, Lieferscheinnummer, Rechnungsnummer, Kundennummer, " & _
    "Name_1, Name_2, Name_3, Land, Plz, Strasse, Ort, " & _
    "Paketscheinnummer1, Listennummer, Pakete, Gewicht, Gewicht2, Gewicht3 " & _
"FROM Lieferung_Tabelle " & _
"WHERE (Datum BETWEEN #" & Month(datAnfang) & "/" & Day(datAnfang) & _
    "/" & Year(datAnfang) & "# And #" & _
    Month(datEnde) & "/" & Day(datEnde) & "/" & Year(datEnde) & "#) " & _
"ORDER BY Land, Datum, Pakete, Gewicht"

With ActiveSheet.QueryTables.Add(Connection:=strDBOpen, Destination:=Range("A3"), Sql:=strSQL)
.Refresh BackgroundQuery:=False
.RefreshOnFileOpen = False
End With

Daten aus einer Datenbank mit SQL direkt importieren
Dim strDBOpen, strSQL As String

' DBORA wurde mit odbcad32.exe unter SYSTEM-DSN mit dem Datenbank-Treiber angelegt.
strDBOpen = "ODBC;DSN=DBORA"

strSQL = "SELECT * FROM Tabelle"

With ActiveSheet.QueryTables.Add(Connection:=strDBOpen, Destination:=Range("A1"), Sql:=strSQL)
.Refresh BackgroundQuery:=False
.RefreshOnFileOpen = False
End With

Eine UTF8-codierte Text-Datei nach einem Zeichen durchsuchen
' sequentielles Lesen einer Text-Datei
Sub Suchen()
Dim strDateiname As String
Dim intFree As Integer
Dim intPosition As Integer
Dim strZeichen As String
Dim lngZähler As Long
Dim lngZeilennummer As Long
Dim strZeile As String

strDateiname = "LW:\Pfad\SZ.htm"
intFree = FreeFile()
lngZähler = 0
lngZeilennummer = 0
strZeichen = "ÃŸ"' für das Zeichen ß in UTF-8

Columns("A:B").Select
Selection.Clear

Open strDateiname For Input As intFree
Do Until EOF(intFree)
   lngZeilennummer = lngZeilennummer + 1
   Line Input #intFree, strZeile

   intPosition = InStr(strZeile, strZeichen)

   If intPosition > 0 Then
    lngZähler = lngZähler + 1
    Cells(lngZähler, 1).Value = lngZeilennummer
    Cells(lngZähler, 2).Value = strZeile
   End If
Loop
Close intFree

If lngZähler > 0 Then
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Selection.Font.Bold = True
Selection.HorizontalAlignment = xlCenter
Columns("A:A").Select
Selection.HorizontalAlignment = xlCenter
Columns("B:B").AutoFit
Cells(1, 1).Value = "Nummer"
Cells(1, 2).Value = "Inhalt"
Cells(lngZähler + 1, 2).Select
Else
Cells(1, 1).Select
End If

End Sub

Tabellenblatt nach HTML exportieren
Option Explicit
#If VBA7 Then
Declare PtrSafe Sub ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long)
#Else
Declare Sub ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long)
#End If

Sub HtmlExport()
' bei neuer Saison ändern: strDateiname, strSaison, Sheet, META, Weite

Dim objIE As Object' Internet Explorer
Dim Zelle As Range
Dim strZellArt As String' für die Formatierung
Dim strDateiname As String
Dim intFree As Integer
Dim strSaison As String' für Title, H1 und Table-Title
Dim Zähler As Integer

intFree = FreeFile()
strDateiname = "LW:\Pfad\cl2017.htm"
strSaison = "Champions League 2016 / 2017"
Zähler = 0

ActiveWorkbook.Save
ActiveWorkbook.Sheets("2017").Activate

Open strDateiname For Output As #intFree
Print #intFree, "<!DOCTYPE HTML PUBLIC " & Chr$(34) & "-//W3C//DTD HTML 4.01 Transitional//EN" & Chr$(34)
Print #intFree, " & Chr$(34) & "http://www.w3.org/TR/html4/loose.dtd" & Chr$(34) & ">"
Print #intFree, "<HTML>"
Print #intFree, "<HEAD>"
Print #intFree, ""
Print #intFree, "<META HTTP-EQUIV=" & Chr$(34) & "CONTENT-TYPE" & Chr$(34) & " CONTENT=" & Chr$(34) & _
  "text/html; charset=ISO-8859-1" & Chr$(34) & ">"
Print #intFree, "<META NAME=" & Chr$(34) & "DESCRIPTION" & Chr$(34) & " CONTENT=" & Chr$(34) & _
  "Autor Fussball Champions League" & Chr$(34) & ">"
Print #intFree, "<META NAME=" & Chr$(34) & "OWNER" & Chr$(34) & " CONTENT=" & Chr$(34) & _
  "Eigentümer" & Chr$(34) & ">"
Print #intFree, "<META NAME=" & Chr$(34) & "AUTHOR" & Chr$(34) & " CONTENT=" & Chr$(34) & _
  "Autor" & Chr$(34) & ">"
Print #intFree, "<META NAME=" & Chr$(34) & "KEYWORDS" & Chr$(34) & " CONTENT=" & Chr$(34) & _
  "Fussball, Fußball, Champions League, 2016, 2017" & Chr$(34) & ">"
Print #intFree, "<META HTTP-EQUIV=" & Chr$(34) & "EXPIRES" & Chr$(34) & " CONTENT=" & Chr$(34) & _
  "0" & Chr$(34) & ">"
Print #intFree, ""
Print #intFree, "<TITLE>" & strSaison & "</TITLE>"
Print #intFree, ""
Print #intFree, "<style type=" & Chr$(34) & "text/css" & Chr$(34) & ">"
Print #intFree, ""
Print #intFree, "</style>"
Print #intFree, ""
Print #intFree, "</HEAD>"
Print #intFree, ""
Print #intFree, "<BODY>"
Print #intFree, ""
Print #intFree, "<H1>" & strSaison & "</H1>"
Print #intFree, ""
Print #intFree, "<TABLE title=" & Chr$(34) & strSaison & Chr$(34) & ">"
Print #intFree, ""

For Each Zelle In ActiveSheet.UsedRange.Cells
' neue Zeile
If Zähler = 0 Then
  Print #intFree, "<TR>"
End If

strZellArt = ""

' bei Zelle mittig und nicht leer, dann Klasse mitte
If Zelle.HorizontalAlignment = xlCenter And Not (IsEmpty(Zelle) Or Zelle.Value = "") Then
  strZellArt = "mitte"
End If

' bei Zelle fett formatiert und nicht leer, dann grün oder fett bei mittig
If Zelle.Font.Bold = True And Not (IsEmpty(Zelle) Or Zelle.Value = "") Then
  If Zelle.HorizontalAlignment = xlCenter Then
    strZellArt = "fett"
  Else
    strZellArt = "gruen"
  End If
End If

If strZellArt = "" Then
   strZellArt = "<TD"
Else
  strZellArt = "<TD class=" & Chr$(34) & strZellArt & Chr$(34)
End If

Print #intFree, strZellArt & ">"

If IsEmpty(Zelle) Or Zelle.Value = "" Then
  Print #intFree, " "
Else
  Print #intFree, Zelle.Value
End If

Print #intFree, "</TD>"

Zähler = Zähler + 1

If Zähler = ActiveSheet.UsedRange.Columns.Count Then
  Print #intFree, "</TR>"
  Zähler = 0
End If
Next Zelle

Print #intFree, ""
Print #intFree, "</TABLE>"
Print #intFree, ""
Print #intFree, "</BODY>"
Print #intFree, "</HTML>"

Close #intFree

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True' Das Fenster sichtbar machen.
objIE.Navigate strDateiname
ShowWindow objIE.hwnd, 3' Das Fenster maximieren. (siehe Deklaration)
Set objIE = Nothing

End Sub

Eine Datei sitemap.xml für eine Homepage erstellen
Option Explicit
#If VBA7 Then
Declare PtrSafe Sub ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long)
#Else
Declare Sub ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long)
#End If

Sub Anzeigen()
Dim objIE As Object' Internet Explorer
Dim fs, f, f1, fc As Object
Dim Dateinummer
Dim strPfad, XmlDatei, strDatei, strLast, strZeile As String
Dim strZusatz As String
Dim strZeit, strJahr, strMonat, strTag, strStunde, strMinute, strSekunde As String
Dim Zelle As Range
Dim intZähler As Integer
Dim Antwort As Variant

Set objIE = CreateObject("InternetExplorer.Application")

' Der Pfad zu den Webseiten steht in der Zelle A2 mit einem \ am Ende.
strPfad = Cells(2, 1).Value

Columns("B:D").Select
Selection.ClearContents

Cells(1, 2).Value = "Dateien:"
Cells(1, 3).Value = "Größe:"
Cells(1, 4).Value = "Änderung:"

Cells(2, 2).Select
Set Zelle = Cells(2, 2)
intZähler = 0

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strPfad)
Set fc = f.Files

' FreeFile wird erst nach dem Öffnen der Datei erhöht.
Dateinummer = Freefile
XmlDatei = strPfad & "sitemap.xml"

Open XmlDatei For Output As #Dateinummer
Print #Dateinummer, Chr(&HEF); Chr(&HBB); Chr(&HBF);
Print #Dateinummer, "<?xml version=" & Chr$(34) & "1.0" & Chr$(34) & " encoding=" & Chr$(34) & "UTF-8" & Chr$(34) & "?>"
Print #Dateinummer, ""
Print #Dateinummer, "<urlset xmlns=" & Chr$(34) & "http://www.sitemaps.org/schemas/sitemap/0.9" & Chr$(34)
Print #Dateinummer, " xmlns:xsi=" & Chr$(34) & "http://www.w3.org/2001/XMLSchema-instance" & Chr$(34)
Print #Dateinummer, " xsi:schemaLocation=" & Chr$(34) & "http://www.sitemaps.org/schemas/sitemap/0.9"
Print #Dateinummer, " http://www.sitemaps.org/schemas/sitemap/0.9/sitemap.xsd" & Chr$(34) & ">"
Print #Dateinummer, ""

For Each f1 In fc
If f1.Name = "index.htm" Then' Startseite der Homepage
  strLast = Str(f1.dateLastModified)

  strTag = Left(strLast, 2)
  strMonat = Mid(strLast, 4, 2)
  strJahr = Mid(strLast, 7, 4)
  strStunde = Mid(strLast, 12, 2)
  strMinute = Mid(strLast, 15, 2)
  strSekunde = Right(strLast, 2)

   strZeit = strJahr & "-" & strMonat & "-" & strTag & "T" & strStunde & ":" & strMinute & ":" & _
    strSekunde & "+01:00"

   strZeile = "<url><loc>https://www.uwelindner.de/</loc><lastmod>" & strZeit & _
    "</lastmod><changefreq>weekly</changefreq><priority>0.80</priority></url>"
   Print #Dateinummer, GetUTF8String(strZeile)

  Exit For
End If
Next

For Each f1 In fc
If LCase$(fs.GetExtensionName(f1)) = "htm" Then' nur Dateien mit der Endung htm
   If Right(fs.GetBaseName(f1), 7) <> "frames1" Then' ohne die Datei frames1.htm
    If Left(fs.GetBaseName(f1), 9) <> "impressum" Then' ohne die Dateien impressum*.htm
     strDatei = f1.Name
     Zelle.Value = f1.Name
     Set Zelle = Zelle.Offset(0, 1)

     Zelle.Value = f1.Size
     Set Zelle = Zelle.Offset(0, 1)

     strLast = Str(f1.dateLastModified)
     Zelle.Value = f1.dateLastModified

     strTag = Left(strLast, 2)
     strMonat = Mid(strLast, 4, 2)
     strJahr = Mid(strLast, 7, 4)
     strStunde = Mid(strLast, 12, 2)
     strMinute = Mid(strLast, 15, 2)
     strSekunde = Right(strLast, 2)

     strZeit = strJahr & "-" & strMonat & "-" & strTag & "T" & strStunde & ":" & strMinute & ":" & _
      strSekunde & "+01:00"

     strZusatz = "<changefreq>monthly</changefreq>"

     If fs.GetBaseName(f1) = "zitate" Then' für die Datei zitate.htm
      strZusatz = "<changefreq>daily</changefreq><priority>0.80</priority>"
     End If

     strZeile = "<url><loc>https://www.uwelindner.de/" & strDatei & "</loc><lastmod>" & _
      strZeit & "</lastmod>" & strZusatz & "</url>"
     Print #Dateinummer, GetUTF8String(strZeile)

     Set Zelle = Zelle.Offset(1, -2)
     Zelle.Select

     intZähler = intZähler + 1
   End If
  End If
End If
Next

Print #Dateinummer, ""
Print #Dateinummer, "</urlset>"
Close #Dateinummer

Columns("A:D").AutoFit
Range("B2").Select
ActiveWorkbook.Save

Antwort = MsgBox(Str(intZähler) & " Dateien vorhanden", vbInformation, "Sitemap")

objIE.Visible = True' Das Fenster sichtbar machen.
objIE.Navigate HtmlDatei

' Warten bis die Seite geladen ist
Do While objIE.Busy
Loop

' Das Fenster maximieren.
ShowWindow objIE.hwnd, 3' muss außerhalb von Sub deklariert werden (siehe oben)

Set objIE = Nothing
Set fs = Nothing
Set f = Nothing
Set f1 = Nothing
Set fc = Nothing

End Sub

Dateien eines Pfades einlesen mit dem Änderungsdatum absteigend sortiert
Option Explicit

Sub DatumAbsteigend()
Dim fs, f, f1, fc As Object
Dim strPfad As String
Dim arrNamen() As String
Dim arrDatum() As Date
Dim i As Long
Dim j As Long
Dim n As Long
Dim strTemp As String
Dim datTemp As Date
Dim Zelle As Range

' Der Pfad Dateien steht in der Zelle A2 mit einem \ am Ende.
strPfad = Cells(2, 1).Value

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strPfad)
Set fc = f.Files

n = fc.Count
ReDim arrNamen(1 To n)
ReDim arrDatum(1 To n)

For Each f1 In fc
i = i + 1
arrNamen(i) = f1.Name
arrDatum(i) = f1.DateLastModified
Next f1

' Das Array nach Datum absteigend sortieren
For i = 1 To n - 1
For j = i + 1 To n
   If arrDatum(i) < arrDatum(j) Then
    datTemp = arrDatum(i)
    arrDatum(i) = arrDatum(j)
    arrDatum(j) = datTemp
    strTemp = arrNamen(i)
    arrNamen(i) = arrNamen(j)
    arrNamen(j) = strTemp
   End If
Next j
Next i

Columns("B:C").Select
Selection.ClearContents

Cells(1, 2).Value = "Dateien:"
Cells(1, 3).Value = "Änderung:"

Cells(2, 2).Select
Set Zelle = Cells(2, 2)

For i = 1 To n
Zelle.Value = arrNamen(i)
Set Zelle = Zelle.Offset(0, 1)
Zelle.Value = arrDatum(i)
Set Zelle = Zelle.Offset(1, -1)
Next i

End Sub

Spalten-Überschriften formatieren
' vor dem Festlegen der optimalen Spaltenbreite
Rows("1:1").Select

With Selection
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Optimale Spaltenbreite festlegen
ActiveSheet.Columns.AutoFit
Columns("E:E").AutoFit

Spaltenbreite auf Standard ändern
ActiveSheet.Columns.ColumnWidth = 10.71

Spaltenüberschriften von Zeile 1 auf jeder Seite drucken
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
End With

Seite einrichten
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.LeftHeader = "Text"
.CenterHeader = "&A"' Name des Tabellenblatts einfügen
.RightHeader = "&D &T"' Datum und Zeit einfügen
.CenterFooter = "&F"' den Dateinamen einfügen
.RightFooter = "Seiten &P von &N" ' Seite aktuell von Gesamt-Anzahl
.PrintGridlines = True
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape' oder xlPortrait für das Hochformat
.Order = xlOverThenDown' Druckreihenfolge bei mehreren Seiten breit: erst Zeile, dann Spalte
.BlackAndWhite = True' Schwarz-Weiß-Druck
.Zoom = False' oder .Zoom = 100 (in Prozent; ohne die FitToPages-Optionen)
.FitToPagesWide = 1' eine Seite breit
.FitToPagesTall = False
End With

Druckbereich festlegen
ActiveSheet.PageSetup.PrintArea = "$A:$E"

Tabelle drucken
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

Tabelle schützen
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

Blattschutz aufheben
Sub BlattschutzAufheben()
On Error Resume Next

For i = 65 To 66

For j = 65 To 66

For k = 65 To 66

For l = 65 To 66

For m = 65 To 66

For n = 65 To 66

For o = 65 To 66

For p = 65 To 66

For q = 65 To 66

For r = 65 To 66

For s = 65 To 66

For t = 32 To 126

ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & Chr(l) & Chr(m) & _
Chr(n) & Chr(o) & Chr(p) & Chr(q) & Chr(r) & Chr(s) & Chr(t)

Next t

Next s

Next r

Next q

Next p

Next o

Next n

Next m

Next l

Next k

Next j

Next i

MsgBox "Der Blattschutz wurde aufgehoben."

End Sub

Wordart in die aktive Tabelle einfügen und mit gleichnamigen Makro verknüpfen
Sub EinfügenButton()
Dim objShape As Shape

Application.Windows(Datei.xls").Activate' Die Datei muss geöffnet sein.
Sheets("Start").Select' Das Tabellenblatt muss vorhanden sein

ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Delete' Alle Buttons löschen

ActiveSheet.Shapes.AddTextEffect(msoTextEffect48, "Anzeigen", _
"+mn-lt", 54, msoTrue, msoFalse, 600, 50).Select

ActiveSheet.Shapes.AddTextEffect(msoTextEffect48, "Sortieren", _
"+mn-lt", 54, msoTrue, msoFalse, 600, 150).Select

ActiveSheet.Shapes.AddTextEffect(msoTextEffect48, "Duplikate", _
"+mn-lt", 54, msoTrue, msoFalse, 600, 250).Select

ActiveSheet.Shapes.AddTextEffect(msoTextEffect48, "Umbenennen", _
"+mn-lt", 54, msoTrue, msoFalse, 600, 350).Select

For Each objShape In ActiveSheet.Shapes
If objShape.TextFrame2.TextRange.Text = "Anzeigen" Then
  objShape.OnAction = "Anzeigen"
End If

If objShape.TextFrame2.TextRange.Text = "Sortieren" Then
  objShape.OnAction = "Sortieren"
End If

If objShape.TextFrame2.TextRange.Text = "Duplikate" Then
objShape.OnAction = "Duplikate"
End If

If objShape.TextFrame2.TextRange.Text = "Umbenennen" Then
  objShape.OnAction = "Umbenennen"
End If
Next objShape

End Sub

Zwischenablage vor dem Schließen der Datei leeren
' in den Deklarationen
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
#Else
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard& Lib "user32" ()
#End If

Public Sub ClearClipboard()
OpenClipboard 0&
EmptyClipboard
CloseClipboard
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
ClearClipboard
End Sub

Arbeitsmappe speichern unter
ActiveWorkbook.SaveAs Filename:=strDateiName, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Arbeitsmappe speichern unter als Excel 97-2003-Arbeitsmappe
ActiveWorkbook.SaveAs Filename:="LW:\Pfad\Datei2.xls", _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

Arbeitsmappe speichern unter als *.xlsx im XML-Format
ActiveWorkbook.SaveAs Filename:="LW:\Pfad\Datei2.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

Tabelle speichern unter als PDF-Datei
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="LW:\Pfad\Datei.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

Tabelle speichern unter als CSV-Datei
' Die Spalten sind durch ein Semikolon getrennt. (siehe Länder-Einstellungen)
ActiveWorkbook.SaveAs Filename:= "LW:\Pfad\Datei.csv", FileFormat:=xlCSV, _
CreateBackup:=False

Arbeitsmappe speichern und schließen
ActiveWorkbook.Save
ActiveWorkbook.Close

Arbeitsmappe ohne Speichern schließen
Workbooks("Temp.xls").Close SaveChanges:=False

MS Word verwenden
' Die Dezimal-Punkte in einer Text-Datei durch ein Komma ersetzen.
Sub AppWord()
Dim wordAnw As Object

Set wordAnw = CreateObject("word.application")

With wordAnw
.Documents.Open FileName:="LW:\Pfad\Original.txt"

With .ActiveDocument
   ' .Visible = True' Word im Vordergrund
   .Content.Find.Execute FindText:=".", ReplaceWith:=",", Replace:=2
  .SaveAs FileName:="LW:\Pfad\Import.txt"
  .Close
End With

.Quit
End With

Set wordAnw = Nothing

Workbooks.OpenText FileName:="LW:\Pfad\Import.txt", DataType:=xlDelimited, Semicolon:=True
ActiveWorkbook.SaveAs FileFormat:=xlNormal

End Sub

Word

Globale Makros des Benutzers
%appdata%\Microsoft\Templates\Normal.dotm

Makro beim Öffnen des Dokuments ausführen
Sub AutoOpen()
MsgBox ("AutoOpen")
End Sub

Makro bei einem neuen Dokument einer Vorlage ausführen
Sub AutoNew()
MsgBox ("AutoNew")
End Sub

Einfügen aus der Zwischenablage ohne Formate
Sub EinfügenOhneFormate()
Selection.PasteAndFormat(wdFormatPlainText)
End Sub

Dokument im Dialog öffnen
Sub Öffnen()

Dim OpenDlg As Dialog
Set OpenDlg = Dialogs(wdDialogFileOpen)

With OpenDlg
.Name = Environ("USERPROFILE") & "\Documents"
If .Display() = True Then
.Execute
End If
Set OpenDlg = Nothing
End With

End Sub

Ganzes Dokument markieren
Selection.WholeStory

Seite einrichten im Querformat
ActiveDocument.PageSetup.Orientation = wdOrientLandscape

Ansicht: Entwurf
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
ActiveWindow.ActivePane.View.Type = wdNormalView
Else
ActiveWindow.View.Type = wdNormalView
End If

Dokument-Ansicht: Zoom auf 100%
ActiveWindow.ActivePane.View.Zoom.Percentage = 100

Ansicht: Navigationsbereich
ActiveWindow.DocumentMap = True
ActiveWindow.DocumentMap = False

Wechseln zur Seite 2
Selection.GoTo What:=wdGoToPage, Count:=2

Wechseln zum Dateiende
Selection.GoTo What:=wdGoToLine, Which:=wdGoToLast

Wechseln zur Kopfzeile
With ActiveWindow.View
.Type = wdPageView
.SeekView = wdSeekCurrentPageHeader
End With

Bereich am Anfang des Dokuments festlegen
Set Bereich = ActiveDocument.Range(Start:=0, End:=0)

Bereich am Ende des Dokuments festlegen
Set Bereich = ActiveDocument.Range(Start:=ActiveDocument.Content.End - 1, _
End:=ActiveDocument.Content.End - 1)

Anzeige der aktuellen Zeilennummer
MsgBox "Zeile " & Selection.Information(wdFirstCharacterLineNumber)

Cursor eine Zeile nach unten verschieben
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove

Cursor an das Ende der Zeile verschieben
Selection.EndKey(Unit:=wdLine, Extend:=wdMove)

Zu einer Textmarke wechseln
' evtl. erst: ActiveWindow.View.Type = wdNormalView
Selection.GoTo What:=wdGoToBookmark, Name:="Textmarke 1"

Zwischenablage als Text einfügen
Selection.PasteSpecial Link:=False, DataType:=wdPasteText, Placement:= _
wdInLine, DisplayAsIcon:=False

Zeichenkette nach der aktuellen Position einfügen
Selection.InsertAfter "neuer Text"

Zeichenkette in eine Markierung einfügen
Selection.TypeText Text:="Dokumentation"

Zeile nach der aktuellen Position einfügen
Selection.InsertParagraphAfter

Datei nach der aktuellen Position einfügen
Selection.InsertFile FileName:="LW:\Pfad\Datei.doc"

Einfügen eines Leerzeichens am Anfang jedes Absatzes
For Each Absatz In Bereich.Paragraphs
strAltZeichen = Absatz.Range.Characters(1)

If strAltZeichen <> " " Then
Absatz.Range.Characters(1).InsertBefore " "
End If
Next

Löschen aufeinander folgender Leerzeichen
strAltZeichen = ""

For Each strAktZeichen In Bereich.Characters
If strAktZeichen = " " And strAltZeichen = " " Then
strAktZeichen.Delete
Else
strAltZeichen = strAktZeichen
End If
Next

Ersetzen eines Leerzeichens plus Absatzmarke durch eine Absatzmarke
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = " ^p"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Execute Replace:=wdReplaceAll
End With

Kundennummer im Dokument suchen
Selection.Start = ActiveDocument.Content.Start
Selection.End = ActiveDocument.Content.End

With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Kundennummer"' nach dem Wort suchen
.Format = False
.Forward = True
.Wrap = wdFindStop' Stopp beim 1. Fund
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

If .Execute() = False Then MsgBox ("Die Kundennummer wurde nicht gefunden.")
End With

PosAnfang = Selection.End' Ende-Position der Fundstelle
PosEnde = Selection.Bookmarks("\line").End' bis zum Ende der Zeile

strKunde = ActiveDocument.Range(Start:=PosAnfang + 1, End:=PosEnde - 1)

Aktuelles Datum und die Zeit einfügen
Selection.InsertDateTime DateTimeFormat:="dd.MM.yyyy HH:mm", InsertAsField _
:=False, DateLanguage:=wdGerman, CalendarType:=wdCalendarWestern, _
InsertAsFullWidth:=False

Feld Druckdatum einfügen
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"PRINTDATE \@ ""dd.MM.yyyy HH:mm"" ", PreserveFormatting:=True

In einem Seriendruck-Feld ein Leerzeichen anhängen
' Zwischen den Seriendruck-Feldern in einer Zeile braucht dann kein Leerzeichen zu stehen.
' Im Serienbrief: Menü Sendungen, Vorschau/Ergebnisse zur Ansicht der Seriendruck-Felder umschalten.
' Mit den Tasten <Alt> + <F9> die Ansicht der Seriendruck-Felder zu MERGEFIELD umschalten.
' In das Seriendruck-Feld direkt hinter dessen Bezeichnung klicken und
' den folgenden Befehl in einem Makro ausführen.
Selection.TypeText Text:=" \f " & Chr$(34) & " " & Chr$(34)
' An der aktuellen Position wird eingefügt: \f " "
' Mit den Tasten <Alt> + <F9> die Ansicht der Seriendruck-Felder zurück zu Normal umschalten.
' Im Serienbrief: Menü Sendungen, Vorschau/Ergebnisse zur Kontrolle auf Ansicht Feldinhalt umschalten.

Kopfzeile bearbeiten
Dim strÜberschrift As String

strÜberschrift = "Das ist die Überschrift"

ActiveWindow.ActivePane.View.Type = wdPrintView
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

With Selection.Font
.Name = "Arial"
.Size = 12
.Bold = True
End With

Selection.TypeText Text:="Dokumentation"

With Selection.Font
.Name = "Arial"
.Size = 10
.Bold = False
End With

Selection.TypeText Text:=vbTab & strÜberschrift & vbTab
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldDate, PreserveFormatting:=True
Selection.TypeText Text:=" "
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldTime, PreserveFormatting:=True
Selection.TypeParagraph
Selection.TypeText Text:=vbTab & vbTab
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"FILENAME ", PreserveFormatting:=True
Selection.TypeParagraph
Selection.TypeText Text:=vbTab & vbTab & "Seite "
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldPage, PreserveFormatting:=True
Selection.TypeText Text:=" von "
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldNumPages, PreserveFormatting:=True
Selection.TypeParagraph
Selection.TypeParagraph

ActiveWindow.View.Type = wdNormalView

Zeichenkette in die Registry speichern und abrufen
System.ProfileString("Privat", "EigenerName") = "Name, Vorname"
MsgBox System.ProfileString("Privat", "EigenerName")

Dokument als PDF ohne Öffnen der Datei exportieren
ActiveDocument.ExportAsFixedFormat Outputfilename:="LW:\Pfad\Test.pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
Range:= wdExportAllDocument, Item:=wdExportDocumentContent, _
IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False

Dateiname ohne Punkt und ohne die ungültigen Zeichen ?"/\<>*|
Dim strDatName, strDatNameBind, strDatNeu, strPfad As String
Dim strByte As String * 1
Dim strKorr As String
Dim intZähler As Integer
Dim strAnführZeichen As String * 1

strAnführZeichen = Chr(34)' ergibt ein "
strDatNameBind = ""
strDatNeu = ""
strPfad = "LW:\Pfad\"
strDatName = txtÜberschrift.Text' Zeichenkette aus der Textbox Überschrift für den Dateiname

For intZähler = 1 To Len(strDatName)
strByte = Mid(strDatName, intZähler, 1)

Select Case strByte
   Case ".", "?", strAnführZeichen, "/", "\", "<", ">", "*", "|", ":"
    strKorr = ""
   Case Else
    strKorr = strByte
End Select

strDatNeu = strDatNeu & strKorr
Next intZähler

strDatName = strPfad & strDatNeu

Dokument speichern
Sub Speichern()
ChangeFileOpenDirectory "%USERPROFILE%\Documents\"

ActiveDocument.SaveAs2 FileName:="Datei.docx", _
FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False, CompatibilityMode:=15
End Sub

Aufrufen des Dialogs Speichern unter
Dim strPfadName As String
Dim strDatName As String

' für das Vorbelegen vom Dialog
strPfadName = "LW:\Pfad\"
strDatName = strPfadName & "Brief"

With Dialogs(wdDialogFileSaveAs)
.Name = strDatName
.Show
End With

ActiveDocument.Fields.Update' alle Felder (Datum, Seitenzahl, Speicherort) aktualisieren
ActiveDocument.Save

Dokument ohne Speichern schließen
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges

Liste der Outlook-Kontakte erstellen
Option Explicit

Sub Kontakte()

Dim outApp As Outlook.Application
Dim outMAPI As Outlook.NameSpace
Dim outAdressListe As Outlook.AddressList
Dim outAdressEintrag As AddressEntry

Dim docAusgabe As Word.Document
Dim parAusgabe As Word.Paragraph

Set outApp = New Outlook.Application
Set outMAPI = outApp.GetNamespace("MAPI")

Set outAdressListe = outMAPI.AddressLists("Kontakte")
' Set outAdressListe = outMAPI.AddressLists("Globales Adreßbuch")

MsgBox ("Es gibt " & Str(outAdressListe.AddressEntries.Count) & " Einträge.")

Set docAusgabe = Word.Application.ActiveDocument
Set parAusgabe = docAusgabe.Paragraphs(1)
parAusgabe.Range.Text = "Adressliste"

For Each outAdressEintrag In outAdressListe.AddressEntries
Set parAusgabe = docAusgabe.Paragraphs.Add
With parAusgabe
.Range.InsertAfter Text:=outAdressEintrag.Name
.Style = "Standard"
End With
Next

Word.Application.Activate

End Sub

Text in eine Tabelle umwandeln
' Eine Tabelle mit den Sonderzeichen einer Schriftart in ein leeres Dokument einfügen.
' Die Eingabe eines Sonderzeichens ist mit der gedrückten <Alt>-Taste und
' der Zahl mit der Vornull möglich.

Schriftart="Symbol"' evtl. die Schriftart anpassen
ActiveDocument.Content.Select
Selection.Font.Name = Schriftart

' für die Überschrift der Tabelle mit 5 * 2 Spalten, das Trennzeichen ist der Tabulator
For i = 1 To 5
Selection.InsertAfter Text:="Taste" & Chr(9) & "Zeichen" & Chr(9)
Next i

' Einfügen einer lfd. Zahl mit Vornull und dem Zeichen in der Schriftart ohne Absatz
For i = 33 To 255
Selection.InsertAfter Text:="0" & LTrim(Str(i)) & Chr(9) & Chr(i) & Chr(9)
Next i

ActiveDocument.Content.Select
' den Text in eine Tabelle mit 10 Spalten umwandeln
Set meineTabelle = Selection.ConvertToTable(Separator:=wdSeparateByTabs, NumRows:="32", _
NumColumns:="10", Format:=wdTableFormatGrid3, ApplyBorders:=True, _
ApplyShading:=True, ApplyFont:=True, ApplyColor:=False, ApplyHeadingRows:=True, _
ApplyFirstColumn:=True)

' die Überschrift der Tabelle formatieren
ActiveDocument.Tables(1).Rows(1).Select
Selection.Font.Name = "Arial"

' Eine Überschrift vor der Tabelle einfügen.
' Einen Absatz vor der Tabelle einfügen, da Zeile 1 selektiert ist,
' sonst wird die Tabelle vor der aktuellen Zeile geteilt.
Selection.SplitTable

With ActiveDocument.Content
.InsertParagraphBefore
.InsertParagraphBefore
.InsertBefore Schriftart
.InsertBefore "Sonderzeichen der Schriftart "
End With

Word-Dokument nach HTML5 (UTF8) exportieren
Option Explicit
#If VBA7 Then
Declare PtrSafe Sub ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long)
#Else
Declare Sub ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long)
#End If

Sub HTMLExport()
Dim Absatz As Paragraph
Dim objIE As Object' Internet Explorer
Dim strDateiname As String
Dim intFree As Integer
Dim bolLeer As Boolean' leerer Absatz

bolLeer = False

strDateiname = "LW:\Pfad\Word.htm"
intFree = FreeFile()

Open strDateiname For Output As #intFree

Print #intFree, Chr(&HEF); Chr(&HBB); Chr(&HBF);
Print #intFree, "<!doctype html>"
Print #intFree, ""
Print #intFree, "<html lang=" & Chr$(34) & "de" & Chr$(34) & ">"
Print #intFree, "<head>"
Print #intFree, ""
Print #intFree, "<meta charset=" & Chr$(34) & "utf-8" & Chr$(34) & " />"
Print #intFree, "<meta name=" & Chr$(34) & "description" & Chr$(34) & " content=" _
  & Chr$(34) & "Word" & Chr$(34) & " />"
Print #intFree, "<meta name=" & Chr$(34) & "author" & Chr$(34) & " content=" _
  & Chr$(34) & "Max Mustermann" & Chr$(34) & " />"
Print #intFree, "<meta name=" & Chr$(34) & "keywords" & Chr$(34) & " content=" _
  & Chr$(34) & "Word" & Chr$(34) & " />"
Print #intFree, ""
Print #intFree, "<title>Word</title>"
Print #intFree, ""
Print #intFree, "<style>"
Print #intFree, "html, body {"
Print #intFree, "  font-family:Calibri,Arial,Helvetica,sans-serif;"
Print #intFree, "  font-size:18px;"
Print #intFree, "  font-weight:bold;"
Print #intFree, "  color:#000000;"
Print #intFree, "  background-color:#ffffff;"
Print #intFree, " }"
Print #intFree, ""
Print #intFree, "h1 { text-align:center; color:#007a66; letter-spacing:3px; }"
Print #intFree, ""
Print #intFree, "p { width:800px; text-align:left; margin:20px auto; }"
Print #intFree, ""
Print #intFree, "@media print {"
Print #intFree, "html, body {"
Print #intFree, "  color:#000000; background-color:#ffffff;"
Print #intFree, "  font-size:16px;"
Print #intFree, "  font-weight:normal;"
Print #intFree, " }"
Print #intFree, ""
Print #intFree, "h1 { color:#000000; }"
Print #intFree, ""
Print #intFree, "p { width:100%; }"
Print #intFree, "}"
Print #intFree, "</style>"
Print #intFree, "</head>"
Print #intFree, "<body>"
Print #intFree, ""
Print #intFree, "<h1>Word</h1>"
Print #intFree, ""
Print #intFree, "<p>"

For Each Absatz In ActiveDocument.Paragraphs
If Absatz.Range.Characters.Count > 1 Then
  bolLeer = False
  Print #intFree, GetUTF8String(Absatz.Range.Text) & "<br />"
Else
   If bolLeer = True Then' Der vorherige Absatz war leer.
    Print #intFree, " "
   End If

  Print #intFree, "</p>"
  Print #intFree, ""
  Print #intFree, "<p>"
  bolLeer = True
End If
Next

If bolLeer = True Then' Der vorherige Absatz war leer.
Print #intFree, " "
End If

Print #intFree, "</p>"
Print #intFree, ""
Print #intFree, "</body>"
Print #intFree, "</html>"

Close #intFree

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True' Das Fenster sichtbar machen.
objIE.Navigate strDateiname
ShowWindow objIE.hwnd, 3' Das Fenster maximieren. (siehe Deklaration)
Set objIE = Nothing

End Sub

Private Function GetUTF8String(s As String) As String
Dim i As Integer' Zähler über die einzelnen Zeichen des utf16-Strings
Dim utf16 As Long, uc(2) As Byte

GetUTF8String = ""
For i = 1 To Len(s)
utf16 = AscW(Mid(s, i, 1))
If utf16 < 0 Then utf16 = utf16 + 65536
If utf16 < &H80 Then' 1 Byte
   GetUTF8String = GetUTF8String & Chr(utf16)
ElseIf utf16 < &H800 Then' 2 Byte
   uc(1) = &H80 + (utf16 And &H3F)' Least Significant 6 bits
   utf16 = utf16 \ &H40' Shift UTF16 number right 6 bits
   uc(0) = &HC0 + (utf16 And &H1F)' Use 5 remaining bits
   GetUTF8String = GetUTF8String & Chr(uc(0)) & Chr(uc(1))
Else' 3 Byte
   uc(2) = &H80 + (utf16 And &H3F)' Least Significant 6 bits
  utf16 = utf16 \ &H40' Shift UTF16 number right 6 bits
  uc(1) = &H80 + (utf16 And &H3F)' Use next 6 bits
  utf16 = utf16 \ &H40' Shift UTF16 number right 6 bits again
  uc(0) = &HE0 + (utf16 And &HF)' Use 4 remaining bits
  GetUTF8String = GetUTF8String & Chr(uc(0)) & Chr(uc(1)) & Chr(uc(2))
End If
Next
End Function

Falz-Markierungen erstellen (Word-Basic)
Public Sub MAIN()

WordBasic.StartOfDocument

Markieren "9,6 cm"
WordBasic.LineDown
Markieren "14,58 cm"
WordBasic.LineDown
Markieren "19,5 cm"

End Sub

' Funktion Markieren mit einem Parameter
Private Sub Markieren(M$)

WordBasic.InsertFrame
WordBasic.FontSize 4

WordBasic.FormatFrame _
  Wrap:=1, _
  WidthRule:=1, _
  FixedWidth:="0,2 cm", _
  HeightRule:=2, _
  FixedHeight:="0,2 cm", _
  PositionHorz:="0,5 cm", _
  PositionHorzRel:=1, _
  DistFromText:="0 cm", _
  PositionVert:=M$, _
  PositionVertRel:=1, _
  DistVertFromText:="0 cm", _
  MoveWithText:=0

WordBasic.FormatBordersAndShading _
  FromText:="0 pt", _
  ApplyTo:=0, _
  Shadow:=0, _
  TopBorder:=0, _
  BottomBorder:=1, _
  LeftBorder:=0, _
  RightBorder:=0, _
  HorizBorder:=0, _
  VertBorder:=0

End Sub

Outlook

E-Mail erstellen
Option Explicit

Dim objOutlook As Object
Dim objMail As Object

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(olMailItem)

With objMail
.To = "Cuche, Didier" ' aus dem Adressbuch oder mail@didier-cuche.ch

.Subject = "Das ist der Betreff"

.Body = "Hallo, " & vbCr & vbCr & _
  "hier steht der Text." & _
  vbCr & vbCr & vbCr & _
  "mit freundlichen Grüßen" & vbCr & vbCr & vbCr & _
  "Herrmann Maier"

.Attachments.Add Source:="C:\boot.ini", DisplayName:="Das ist die Datei Boot.ini"

.Display' Das Mail erst anzeigen oder mit .Send direkt versenden.
End With

Set objMail = Nothing
Set objOutlook = Nothing

Excel: E-Mail mit Signatur und Anlage erstellen
Word: Liste der Kontakte

Menü ausblenden
Allgemein
VBA 64-Bit
Excel
Word
Outlook