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
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
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, Menü Ansicht, Projekt-Explorer, 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, "HTML, BODY {"
Print #intFree, " font-family:Helvetica,sans-serif;"
Print #intFree, " font-weight:bold;"
Print #intFree, "}"
Print #intFree, ""
Print #intFree, "H1 { color:#00AA00; letter-spacing:2px; margin-bottom:30px; margin-left:120px; }"
Print #intFree, ""
Print #intFree, "TABLE {"
Print #intFree, " width:2800px;"
Print #intFree, " background-color:#FFFFFF;"
Print #intFree, " color:#000000;"
Print #intFree, " border:0px; border-spacing:0px;"
Print #intFree, " padding:10px"
Print #intFree, "}"
Print #intFree, ""
Print #intFree, ".gruen { color:#00AA00; }"
Print #intFree, ".fett { color:#00AA00; text-align:center; }"
Print #intFree, ".mitte { text-align:center; }"
Print #intFree, ""
Print #intFree, ""
Print #intFree, "@media print {"
Print #intFree, "HTML, BODY, TABLE, .mitte {"
Print #intFree, " color:#000000; background-color:#FFFFFF;"
Print #intFree, " font-weight:normal;"
Print #intFree, "}"
Print #intFree, ""
Print #intFree, "H1 { color:#000000; }"
Print #intFree, ""
Print #intFree, ".gruen, .fett { color:#000000; font-weight:bold; }"
Print #intFree, "}"
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
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
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