Shareware als Freeware   Freeware   Beispieldateien

Diese Seite richtet sich an Anwender die auf die Schnelle einen Lösungsansatz für ein VBA-Problem benötigen.

Hier wird kein raffiniert programmierter Quellcode gezeigt, sondern übersichtliche Beispiele die man leicht an

eigene Erfordernisse anpassen kann.

Code kopieren: 1. Code markieren | 2. mit Strg+C in Zwischenablage | 3. mit Strg+V in ein Modul einfügen

Umfangreichere Dateien mit nicht geschütztem VBA-Code finden Sie in den Beispieldateien

Wert einer Zelle in die gleiche Zelle aller Tabellenblätter eintragen

'
' NUR EINE DER FUNKTIONEN IN "DieseArbeitsmappe" KOPIEREN
'
' trägt den wert der aktiven zelle in die gleiche zelle aller tabellenblätter ein
'
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 Dim aSh As Worksheet
 Application.EnableEvents = False
 For Each aSh In ThisWorkbook.Worksheets
 If aSh.Range(Target.Address).HasFormula = False Then ' enthält die zelle eine formel
aSh.Range(Target.Address) = Target.Value ' nein, wert wird eingetragen
End If
Next
Application.EnableEvents = True
End Sub
'
' diese funktion markiert zusätzlich in allen tabellenblättern auch die zelle
'
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 Dim aSh As Worksheet
 Dim aSn As String
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 aSn = Sh.Name
 For Each aSh In ThisWorkbook.Worksheets
 If aSh.Range(Target.Address).HasFormula = False Then ' enthält die zelle eine formel
aSh.Range(Target.Address) = Target.Value ' nein, wert wird eingetragen
End If
aSh.Activate
aSh.Range(Target.Address).Select
Next
Sheets(aSn).Activate
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Markierte Zelle einfärben

'----------------------------------------------------------
' färbt eine zelle beim markieren ein. beim verlassen
' der zelle wird wieder die ursprüngliche farbe hergestellt

' weitere infos in der vba-hilfe, stichwort: Color
'----------------------------------------------------------
'

' dieses makro in den code-bereich einer tabelle einfügen
'
Public ZELLE_SAVE As String ' speichert die adresse der zelle
Public FARBE_VG_SAVE As Integer ' speichert die vordergrundfarbe
Public FARBE_HG_SAVE As Integer ' speichert die hintergrundfarbe
Const FARBE_VG = 2 ' vordergrundfarbe beim markieren einer zelle "weiss"
Const FARBE_HG = 5 ' hintergrundfarbe beim markieren einer zelle "blau"
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' verhindert, dass mehr als 1 zelle eingefärbt wird
If Selection.Cells.Count > 1 Then Exit Sub
' setzt die farbe der gespeicherten zelle wieder zurück
If ZELLE_SAVE <> Empty Then
Range(ZELLE_SAVE).Font.ColorIndex = FARBE_VG_SAVE
Range(ZELLE_SAVE).Interior.ColorIndex = FARBE_HG_SAVE
End If
' speichert die hintergrundfarbe der selektierten zelle
FARBE_HG_SAVE = Target.Interior.ColorIndex
' speichert die vordergrundfarbe der selektierten zelle
FARBE_VG_SAVE = Target.Font.ColorIndex
' speichert die adresse der selektierten zelle
ZELLE_SAVE = Target.Address
' hintergrundfarbe der selektierten zelle einfärben
Target.Interior.ColorIndex = FARBE_HG
' vordergrundfarbe der selektierten zelle einfärben
Target.Font.ColorIndex = FARBE_VG
End Sub

Einen Wert nach Eingabe in eine Zelle Formatiert ausgeben

'------------------------------------------------------------
' einen wert nach eingabe in eine zelle formatiert darstellen

' weitere infos in der vba-hilfe, stichwort: Format
'------------------------------------------------------------
'

' dieses makro in den code-bereich einer tabelle einfügen
'
Private Sub Worksheet_Change(ByVal Target As Range)
Dim FORM As String
' beispielformat
FORM = "@@@ | " & Format(Date, "ddd. dd.mm. yyyy")
' ereignisse der tabelle deaktivieren
Application.EnableEvents = False
' zellenwert formatiert ausgeben
Target.Value = "Eigenes Format " & Format(Target.Value, FORM)
' ereignisse der tabelle wieder aktivieren
Application.EnableEvents = True
End Sub

Inhalte von Zellen vergleichen und bei Fehler die zuletzt aktive Zelle markieren

'----------------------------------------------------------------------------------
' vergleicht nach der eingabe den inhalt der aktiven zelle mit einer anderen zelle.
' bei fehlerhafter eingabe wird die zelle mit dem fehler wieder aktiviert

' weitere infos in der vba-hilfe, stichwort: InStr
'----------------------------------------------------------------------------------
'
' dieses makro in den code-bereich einer tabelle einfügen
'
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim ZELLE_AKTIV, ZELLE_VERGLEICH, ZELLE_EINGABE As String
 ' zu prüfende zellen bei eingabe
 ZELLE_EINGABE = "B1 B2 B3 C1 C2 C3 D1 D2 D3"
 ' zu vergleichende zelle
 ZELLE_VERGLEICH = "A5"
 ' Absolute erspart das zeichen $
 ZELLE_AKTIV = Target.Address(RowAbsolute:=False, ColumnAbsolute:=False)
 ' prüft ob die aktive zelle in den zu prüfenden zellen ZELLE_EINGABE enthalten ist
 If InStr(ZELLE_EINGABE, ZELLE_AKTIV) Then
    If Range(ZELLE_AKTIV) <> Range(ZELLE_VERGLEICH) Then
       Fehlermeldung ZELLE_AKTIV, Target.Value, ZELLE_VERGLEICH, Range(ZELLE_VERGLEICH).Value
       ' zuletzt aktive zelle wird wieder aktiviert
       Range(ZELLE_AKTIV).Select
    End If
 End If
End Sub

Sub Fehlermeldung(zelle1, wert1, zelle2, wert2)
 MsgBox "Wert in: " & zelle1 & vbCrLf & wert1 & vbCrLf & vbCrLf & _
    "ist <> Wert in: " & zelle2 & vbCrLf & wert2
End Sub

Letzte Zeile, Letzte Spalte, Letzte Zelle im verwendeten Bereich

Anwendungsbeispiel

' diesen quellcode in ein modul kopieren
'
' globale variablen
Public LETZTE_ZEILE As Long
Public LETZTE_SPALTE As Integer
'-----------------------------------------------------------------
' gibt die LetzteNichtLeereZeile in SPALTE zurück

' weitere infos in der vba-hilfe, stichwort: cell, End-Eigenschaft
'-----------------------------------------------------------------
'
Function LetzteNichtLeereZeile(SPALTE As Integer) As Long
 Dim ZEILE As Long
 ' LetzteNichtLeereZeile ermitteln
ZEILE = Cells(SPALTE).Cells(Columns(SPALTE).Rows.Count, 1).End(xlUp).Row
If Cells(ZEILE, SPALTE) = Empty Then
' gibt 0 zurück, falls keine LetzteNichtLeereZeile existiert

 ' diesen rückgabewert können sie ihren erfordernissen anpassen 
LetzteNichtLeereZeile = 0
Else
LetzteNichtLeereZeile = ZEILE
End If
End Function
'-----------------------------------------------------------------
' gibt die LetzteNichtLeereSpalte in ZEILE zurück
' weitere infos in der vba-hilfe, stichwort: cell, End-Eigenschaft

'-----------------------------------------------------------------
'
Function LetzteNichtLeereSpalte(ZEILE As Long) As Integer
 Dim SPALTE As Integer
 ' LetzteNichtLeereSpalte ermitteln
SPALTE = Cells(ZEILE, Columns.Count).End(xlToLeft).Column
If Cells(ZEILE, SPALTE) = Empty Then
' gibt 0 zurück, falls keine LetzteNichtLeereSpalte existiert

 ' diesen rückgabewert können sie ihren erfordernissen anpassen
LetzteNichtLeereSpalte = 0
Else
LetzteNichtLeereSpalte = SPALTE
End If
End Function
'--------------------------------------------------------
' gibt die LetzteZelle im verwendeten bereich zurück

' weitere infos in der vba-hilfe, stichwort: SpecialCells
'--------------------------------------------------------
'
' funktioniert nur bei ungeschütztem tabellenblatt
'
Function LetzteZelle() As String
 On Error GoTo MsgErr
 ' ermittelt die LETZTE_ZEILE
LETZTE_ZEILE = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
' ermittelt die LETZTE_SPALTE
LETZTE_SPALTE = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
' RowAbsolute und ColumnAbsolute gibt LetzteZelle ohne $ zurück
LetzteZelle = _
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell). _
Address(RowAbsolute:=False, ColumnAbsolute:=False)
Exit Function
MsgErr:
MsgBox "Die Anweisungen:" & vbCrLf & vbCrLf & _
"ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row" & vbCrLf & _
"ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).column" & vbCrLf & vbCrLf & _
"in der Prozedur 'LetzteZelle' können nicht ausgeführt werden" & vbCrLf & vbCrLf & _
Error(Err), , "Fehler"
End Function

Bildschirmgrösse und Bildschirmmitte

' diesen quellcode in ein modul kopieren

'

' ****************
' (c) by Microsoft
' ****************

'
Private Declare Function _
GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function _
GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function _
ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Const HORZRES = 8
Private Const VERTRES = 10
Public Property Get ScreenHeightPixels() As Long
Dim nDC As Long
nDC = GetDC(0)
ScreenHeightPixels = GetDeviceCaps(nDC, VERTRES)
ReleaseDC 0, nDC
End Property
Public Property Get ScreenWidthPixels() As Long
Dim nDC As Long
nDC = GetDC(0)
ScreenWidthPixels = GetDeviceCaps(nDC, HORZRES)
ReleaseDC 0, nDC
End Property
Sub ScreenSize(Optional ScreenWidth, Optional ScreenHeight)
ScreenWidth = ScreenWidthPixels
ScreenHeight = ScreenHeightPixels
End Sub
' ******************
' (c) by Manfred Rüß
' ******************

'
' -----------------------------------------
' gibt die bildschirmgrösse in pixel zurück
' -----------------------------------------
'
Sub Bildschirm()
 Dim ScreenWidth, ScreenHeight As Long
 ScreenSize ScreenWidth, ScreenHeight
 MsgBox "Bildschirmbreite: " & ScreenWidth & vbCrLf & _
 "Bildschirmhöhe: " & ScreenHeight & vbCrLf & _
 "Bildschirmmitte: " & ScreenWidth / 2 & " , " & ScreenHeight / 2, , "Angaben in Pixel"
End Sub

In einer TextBox nur die Eingabe von Ziffern und 1 Komma erlauben

' diesen quellcode in den codebereich einer user-form kopieren

'

' ----------------------------------------------------------------------------
' in textfeld einer user-form nur die einagbe von ziffern und 1 komma erlauben
' ----------------------------------------------------------------------------
'
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
' komma gedrückt?
If KeyAscii <> 44 Then
' nur ziffer 0 - 9 erlauben
If KeyAscii < 48 Or KeyAscii > 57 Then KeyAscii = 0
Else
' nur 1 komma erlauben
If InStr(TextBox1, ",") And KeyAscii = 44 Then KeyAscii = 0
End If
' wenn in der zahl noch kein komma vorhanden ist wird
 ' nach der 5. ziffer ein komma automatisch eingefügt
If Len(TextBox1) = 5 And InStr(TextBox1, ",") = 0 Then TextBox1 = TextBox1 & ","
End Sub
' maximal 8 zeichen in der TextBox1
'
Private Sub UserForm_Initialize()
TextBox1.MaxLength = 8
End Sub

VBProject: Verweise auf eine Objektbibliothek

' diesen quellcode in ein modul kopieren

'

' ----------------------------------------------------------------------
' installiert verweis auf die "Microsoft Outlook Object Library"
' weitere infos in der vba-hilfe, stichwort: COMAddIn, GUID, AddFromGuid
' ----------------------------------------------------------------------
'
Sub OutlookVerweis()
Dim VGUID As String
Dim HAUPTNR, NEBENNR As Long
Dim tWb, VERWEIS As Object
On Error Resume Next
Set tWb = ThisWorkbook
 ' GUID der "Microsoft Outlook Object Library"
 ' GUID kann mit der prozedur VBEVerweise ermittelt werden
VGUID = "{00062FFF-0000-0000-C000-000000000046}"
' installierte verweise durchlaufen
For Each VERWEIS In tWb.VBProject.References
' verweis auf "Microsoft Outlook Object Library" gefunden
If VERWEIS.GUID = VGUID Then
HAUPTNR = VERWEIS.major
NEBENNR = VERWEIS.minor
Exit For
End If
Next
Set VERWEIS = tWb.VBProject.References(VGUID)
' verweis auf "Microsoft Outlook Object Library" löschen
tWb.VBProject.References.Remove VERWEIS
' verweis auf "Microsoft Outlook Object Library" setzen
tWb.VBProject.References.AddFromGuid GUID:=VGUID, major:=HAUPTNR, minor:=NEBENNR
End Sub
' ----------------------------------------------------------------------
' zeigt die in der aktiven arbeitsmappe installierten verweise
' weitere infos in der vba-hilfe, stichwort: COMAddIn, GUID, AddFromGuid
' ----------------------------------------------------------------------
'
Sub VBEVerweise()
Dim HAUPTNR, NEBENNR As Long
Dim tWb, VERWEIS As Object
Dim TASTE As Variant
Set tWb = ThisWorkbook
For Each VERWEIS In tWb.VBProject.References
TASTE = MsgBox("NAME: " & VERWEIS.Name & vbCrLf & _
"GUID: " & VERWEIS.GUID & vbCrLf & _
"DESCRIPTION: " & VERWEIS.Description & vbCrLf & _
"VERZEICHNIS: " & VERWEIS.FullPath & vbCrLf & _
"HAUPTNR: " & VERWEIS.major & vbCrLf & _
"NEBENNR: " & VERWEIS.minor & vbCrLf & vbCrLf & _
"Weiter?", vbYesNo + vbQuestion, "References")
If TASTE = vbNo Then Exit For
Next
End Sub

Eine Arbeitsmappe kann nur mit einer anderen Arbeitsmappe geöffnet werden

'1) Schützen Sie die zu öffnende Arbeitsmappe mit einem Kennwort in Extras/Optionen/Sicherheit

' Vergeben Sie ein Kennwort in Kennwort zum Öffnen und speichern die Arbeitsmappe

'2) Legen Sie eine neue Arbeitsmappe an und speichern Sie diese z.B. unter dem Namen Start.xls

' Drücken Sie die Taste Alt+F11 (öffnet den VBA-Editor)

' Kopieren Sie folgenden Quellcode nach: Microsoft Excel Objekte/DieseArbeitsmappe

Private Sub Workbook_Open()

 Dim Wb_PFAD, Wb_ÖFFNEN, Wb_KENNWORT As String

 On Error GoTo MsgErr

 'pfad zur öffnenden arbeitsmappe

 Wb_PFAD = ThisWorkbook.Path & "\"

 'zu öffnende arbeitsmappe

 Wb_ÖFFNEN = "mappe1.xls"

 'kennwort der zu öffnenden arbeitsmappe

 Wb_KENNWORT = "a"

 'arbeitsmappe öffnen

 Workbooks.Open Filename:=Wb_PFAD & Wb_ÖFFNEN, Password:=Wb_KENNWORT, Notify:=True

 'führt das makro "Start" in der arbeitsmappe Wb_ÖFFNEN (mappe1.xls) aus

 Application.Run (Wb_ÖFFNEN & "!Start")

 Exit Sub

MsgErr:

 MsgBox Error(Err), , "FehlerNr. " & Err

 Err.Clear

End Sub

'In der zu öffnenden Arbeitsmappe (Mappe1.xls) könnte z.B. der folgende Quellcode enthalten sein:

'wird beim start per doppelklick auf Mappe1.xls aufgerufen

Sub auto_open()
 MsgBox "Diese Arbeitsmappe kann nur mit 'Start.xls' geöffnet werden", , "Hinweis"

 ThisWorkbook.Close
End Sub

'wird von Start.xls in Workbook_Open aufgerufen
Sub Start()
MsgBox "Makros in dieser Arbeitsmappe sind aktiviert", , "Hinweis"
End Sub

'Sie müssen den Quellcode natürlich für die Anzeige sperren. Im VBA-Editor unter

'Extras/Eigenschaften von VBA Project/Schutz vergeben Sie ein Kennwort und aktivieren

'Projekt für die Anzeige sperren

'Funktionsweise:

'Startet der Anwender per Doppelklick die Datei Mappe1.xls muss er ein Kennwort eingeben.

'Da dieses nicht bekannt sein dürfte, wird die Arbeitsmappe wieder geschlossen.

'Nun startet der Anwender die Datei Start.xls per Doppelklick. Die Prozedur Workbook_Open öffnet

'die Datei Mappe1.xls, übergibt das Kennwort und führt das Makro Start aus.