VBA-Beispiele für Microsoft Excel

Home

	Verwandte Themen und weitere VBA-Beispiele
	Tipps und Tricks für Microsoft Excel und Excel-VBA Wussten Sie dass...? (Excel, VBA, VBA-Editor) AutoFilter: VBA-Lösungen zu häufig gestellten Fragen The SOSCQ Page: Codebeispiele für VBA und VB

Inhaltsübersicht

[01] Spaltennummer in Spaltenname umwandeln

[02] Zellen mit externen Bezügen auf andere Arbeitsmappen auflisten

[03] Arbeitsblatt- und Arbeitsmappe-Name einer Range-Objektvariable ermitteln

[04] Alle benutzten Zellen einer bestimmten Spalte markieren

[05] Fehlermeldungen von Fehlerzellen auswerten

[06] Anzahl der gefilterten Datensätze ermitteln

[07] Anzahl Zellen mit Kommentaren ausgeben

[08] ZÄHLENWENN über mehrere Tabellenblätter

[09] Zellwerte auf ihre Gültigkeit prüfen

[10] Dokument-Eigenschaften der Arbeitsmappendatei auflisten

[11] AutoFilter-Ergebnisdatensätze in neues Tabellenblatt kopieren

[12] Zwei Zellbereiche miteinander vergleichen, ob sie identisch sind

[13] Ergebnis einer Matrix-Formel in Datenfeldvariable speichern

[14] Arbeitsblätter als Gruppe selektieren

[15] Diagrammblätter als Gruppe selektieren

[16] VBA-Prozedur in bestimmten Zeitabständen ausführen (Timer)

[17] Start- und Ende-Zellen von mehreren selektierten Bereichen auflisten (Jahreskalender)

[18] Aktivierter Zellbearbeitungsmodus feststellen

[19] Arbeitsblatt als GIF- oder JPEG-Datei exportieren

[20] Zellbereich als GIF- oder JPEG-Datei exportieren

[21] Datensätze aus Datenbank in einen Zellbereich abfüllen

[22] Druckbereich eines Tabellenblattes auf andere Tabellenblätter übernehmen

[23] Doppelklick öffnet den in der Zelle angegebenen Ordner im Windows Explorer

[24] Jahreskalender generieren

[25] Tastenkombination Strg+Unterbrechen abfangen und darauf reagieren

[26] Erstes Tabellenblatt aus einem anderen Papierschacht drucken

[27] HÄUFIGKEIT-Funktion mit AutoFilter einsetzen

[28] Mit "Datei öffnen"-Dialog mehrere Arbeitsmappen öffnen

[29] Bildobjekt in der Wiederholungszeile zentrieren

[30] Gesamt-Inhaltsverzeichnis mit Seitenzahlen der Arbeitsblätter erstellen

[31] Steuerelemente zur Laufzeit einem Benutzerformular inkl. Ereignisprozedur hinzufügen

[32] Benutzerdefinierte Excel-Funktion über eine Symbolleisten-Schaltfläche aufrufen

[33] Prüfen, ob die Zellinhalte von zwei Zellbereichen identisch sind

[34] Screen Shot eines Benutzerformulares erstellen und in die Zwischenablage ablegen

[35] Änderung des Formates einer Zelle unterbinden

[36] Erste Zeile einer mit AutoFilter gefilterten Liste abfragen

[37] Warteschleife mit Zehntelsekunden-Auflösung und ohne Application.Wait (VBA/VB)

[38] Berechnungshilfe der Statuszeile nachprogrammieren (Summe, Mittelwert, Anzahl etc.)

[39] Druckbereich unter Berücksichtigung von vorhandenen AutoFormen festlegen

[40] Selektierter Zellbereich als Textdatei exportieren

[41] Daten in zweispaltige Combobox einfüllen

[42] Nur Eingabe von Buchstaben und Ziffern in Textbox zulassen

[43] Ausführung einer mit OnTime geplanten Prozedur verhindern

[44] Auf Taste warten und gedrückte Taste abfragen (VBA/VB)

[45] Spaltennummern von mehreren selektierten Zellbereichen ausgeben

[46] Formelzellen neu berechnen

[1] Spaltennummer in Spaltenname umwandeln

Zusammenfassung
In verschiedenen Situationen ist Ihnen die Spaltennummer bekannt, möchten aber den Namen (z.B. A oder GT) der Spalte wissen, um diesen beispielsweise dem Benutzer anzuzeigen. Die hier vorgestellte Funktion GetColumnName ermittelt den Spaltennamen einer beliebigen Spaltennummer, wobei die Funktion in Excel und in VBA verwendet werden kann. Der Funktion wird eine Spaltennummer zwischen 1 und 256 als Argument übergeben. Wird eine ungültige Spaltennummer angegeben, gibt die Funktion die Fehlerwert "#WERT!" zurück.

VBA-Code
Public Function GetColumnName(ByVal intColumnNumber As Integer) As String
   If intColumnNumber <= 0 Or intColumnNumber > Columns.Count Then
      GetColumnName = "#WERT!"
   Else
      GetColumnName = Left$(Cells(1, intColumnNumber).Address(False, False), _
         Len(Cells(1, intColumnNumber).Address(False, False)) - 1)
   End If
End Function

Syntax
Result = GetColumnName(ColumnIndex)
Result:  Zeichenfolge (String)
ColumnIndex:  Ganzzahl von 1 bis 256 (Integer)

Funktionsaufruf in einer Zelle
=GetColumnName(167)

Funktionsaufruf in VBA
strSpalte = GetColumnName(167)

[2] Zellen mit externen Bezügen auflisten

Zusammenfassung
Excel bietet keine Standardfunktionalität für das Auflisten von externen Bezügen (Bezüge auf andere Quelldateien). Der hier vorgestellte VBA-Code sucht alle Zellen, die im Bezug einen Pfad enthalten und erstellt mit dem Suchergebnis eine Liste auf einem neuen Arbeitsblatt.

VBA-Code
Deklarationsbereich
Option Explicit
Public astrCellAddress() As String
Public astrCellFormula() As String
Public astrCellText() As String

Codebereich
Public Sub ListExternalLinks()
   Dim wksSheet As Worksheet
   Dim intFoundCounter As Integer
   Dim intCounter As Integer
   Dim bolFoundAll As Boolean

   intFoundCounter = 0
   intCounter = 0
   bolFoundAll = False
   Erase astrCellAddress
   Erase astrCellFormula
   Erase astrCellText

   Range("A1").Select

   On Error Resume Next
   Cells.Find(What:=":\", after:=ActiveCell, LookIn:=xlFormulas, LookAt _
      :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
      MatchCase:=False).Activate
   If Err.Number > 0 Then
      MsgBox "Dieses Tabellenblatt enthält keine Zellen mit externen Verknüpfungen."
      Exit Sub
   End If
   On Error GoTo 0

   intFoundCounter = intFoundCounter + 1
   ReDim Preserve astrCellAddress(intFoundCounter)
   ReDim Preserve astrCellFormula(intFoundCounter)
   ReDim Preserve astrCellText(intFoundCounter)
   astrCellAddress(intFoundCounter) = Selection.Address(False, False)
   astrCellFormula(intFoundCounter) = Selection.Formula
   astrCellText(intFoundCounter) = Selection.Text

   Do While Not bolFoundAll
      Cells.FindNext(after:=ActiveCell).Activate
      For intCounter = 1 To intFoundCounter
         If astrCellAddress(intCounter) = Selection.Address(False, False) Then
            bolFoundAll = True
            Exit For
         Else
            bolFoundAll = False
         End If
      Next intCounter

      If bolFoundAll = False Then
         intFoundCounter = intFoundCounter + 1
         ReDim Preserve astrCellAddress(intFoundCounter)
         ReDim Preserve astrCellFormula(intFoundCounter)
         ReDim Preserve astrCellText(intFoundCounter)
         astrCellAddress(intFoundCounter) = Selection.Address(False, False)
         astrCellFormula(intFoundCounter) = Selection.Formula
         astrCellText(intFoundCounter) = Selection.Text
      End If
   Loop

   Set wksSheet = ActiveWorkbook.Worksheets.Add
   With wksSheet
      .Name = "Bezüge"
      .Range("A1").Value = "Zelle"
      .Range("B1").Value = "Externer Bezug"
      .Range("C1").Value = "Zellwert"
      .Range("A1:C1").Font.Bold = True
      For intCounter = 1 To intFoundCounter
         .Cells(intCounter + 1, 1).Value = astrCellAddress(intCounter)
         .Cells(intCounter + 1, 2).Value = "'" & astrCellFormula(intCounter)
         .Cells(intCounter + 1, 3).Value = astrCellText(intCounter)
      Next intCounter
   End With

   wksSheet.Columns("A:C").Select
   Application.Selection.Columns.AutoFit
   wksSheet.Range("A1").Select
   Set wksSheet = Nothing
End Sub

Prozeduraufruf in VBA
[Call] ListExternalLinks

[3] Arbeitsblatt- und Arbeitsmappe-Name einer Range-Objektvariable ermitteln

Zusammenfassung
Es gibt Situationen in denen man eine Objektvariable besitzt und wissen möchte, zu welchem Eltern-Objekt das in der Variable gespeicherte Objekt gehört. In Excel gibt es ein gutes Beispiel dazu. Das Worksheet_Change-Ereignis übergibt eine Objektvariable vom Typ Range mit dem Namen "Target". In Target ist abgelegt, welche Zelle bzw. welcher Zellbereich geändert wurde. Möchte man nun wissen, auf welchem Tabellenblatt und in welcher Arbeitsmappe sich der geänderte Bereich befindet, kann man über die Parent-Eigenschaft des Range-Objektes auf den Namen zugreifen. Das folgende Beispiel zeigt, wie dies in einer Funktion gemacht wird.

VBA-Code
Ereignis-Prozedur des Arbeitsblattes
Private Sub Worksheet_Change(ByVal target As Excel.Range)
   MsgBox ShowMyMessage(target), vbInformation
End Sub

Funktion eines Moduls
Public Function ShowMyMessage(ByVal rngRange As Excel.Range) As String
   ShowMyMessage = "Der Zellinhalt von " & rngRange.Address & " auf Tabellenblatt '" & rngRange.Parent.Name _
      & "' in Arbeitsmappe '" & rngRange.Parent.Parent.Name & "' hat geändert."
End Function

Erläuterung
Wie im obigen Beispielcode zu sehen ist, wird mittels rngRange.Parent.Name der Arbeitsblatt-Name und mittels rngRange.Parent.Parent.Name der Arbeitsmappe-Name ermittelt.

[4] Alle benutzte Zellen einer bestimmten Spalte markieren

Zusammenfassung
Das Markieren einer gesamten Spalte der aktiven Zelle ist den meisten Excel VBA-Programmierern bekannt. Dies wird mit ActiveCell.EntireColumn.Select vorgenommen. Anders sieht es aus, wenn nur diejenigen Spaltenzellen markiert werden sollen, die einen Inhalt besitzen. VBA beziehungsweise das Excel-Objektmodell kennt dafür keine Eigenschaft oder Methode. Um das Gewünschte zu erreichen, muss eine kleine VBA-Prozedur eingesetzt werden.

VBA-Code
Public Sub SelectColumnUsedCells()
   Dim rngUpBound As Range
   Dim rngLowBound As Range
   If ActiveCell.Row > 1 And Not IsEmpty(ActiveCell) Then
      If IsEmpty(ActiveCell.Offset(-1, 0)) Then
         Set rngUpBound = ActiveCell
      Else
         Set rngUpBound = ActiveCell.End(xlUp)
      End If
   Else
      Set rngUpBound = ActiveCell
   End If
   If ActiveCell.Row < Rows.Count And Not IsEmpty(ActiveCell) Then
      If IsEmpty(ActiveCell.Offset(1, 0)) Then
         Set rngLowBound = ActiveCell
      Else
         Set rngLowBound = ActiveCell.End(xlDown)
      End If
   Else
      Set rngLowBound = ActiveCell
   End If
   Range(rngUpBound.Address, rngLowBound.Address).Select
   Set rngUpBound = Nothing
   Set rngLowBound = Nothing
End Sub

Prozeduraufruf in VBA
[Call] SelectColumnUsedCells

[5] Fehlermeldungen von Fehlerzellen auswerten

Zusammenfassung
Steht in einer Zelle ein Fehlerwert, beispielsweise "#NAME?", so kann der Fehlerwert mit dieser Direktfenster-Abfrage ermittelt werden:

  ?Range("A1").Text    'liefert "#NAME?"

Wenn man anstelle der Text-Eigenschaft die Value-Eigenschaft abfragt, wird nicht der Fehlerwert sondern die Fehlernummer ausgegeben:

  ?Range("A1").Value   'liefert "Fehler 2029"

Beim Abfragen der Value-Eigenschaft erhält man also nicht das gleiche Resultat wie bei der Text-Eigenschaft.

Diese Tabelle zeigt die sieben Fehlerwerte/Fehlernummern, die in Microsoft Excel existieren:

[6] Anzahl der gefilterten Datensätze ausgeben

Zusammenfassung
Ich ermittle jeweils die Datensätze durch Zählen der Areas-Zeilen, was mit einer For-Each-Schleife erledigt wird. Das ist m.E. am einfachsten, da die Grösse des Datenbereiches nicht bekannt sein muss und auch auf leere Zellen nicht geachtet werden muss. Bei einer Formellösung wie =TEILERGEBNIS(3;B2:B95) muss man den Zellbereich angeben (und dieser kann sich ja ändern, z.B. durch Hinzufügen oder Löschen von Zeilen). Zudem muss man sich in der Formel auf eine bestimmte Spalte festlegen. Sobald jedoch in der Spalte leere Zellen vorkommen, liefert TEILERGEBNIS ein falsches Resultat, weil nur nicht-leere Zellen gezählt werden.

Der Nachteil einer VBA-Lösung ist allerdings, dass das Makro explizit ausgeführt werden muss - durch Klicken einer Schaltfläche oder wie auch immer. Das Makro kann leider nicht als benutzerdefinierte Excelfunktion verpackt werden, weil dann CurrentRegion und SpecialCells(xlVisible) nicht mehr korrekt funktionieren.

VBA-Code  (Variante A)
Public Sub CountFilteredRows()
   Dim rngUpperLeftCell As Range
   Dim lngRowCount As Long
   Dim rngArea As Range
   Set rngUpperLeftCell = Worksheets("Tabelle1").Range("A1")
   For Each rngArea In rngUpperLeftCell.CurrentRegion.SpecialCells(xlVisible).Areas
      lngRowCount = lngRowCount + rngArea.Rows.Count
   Next
   Application.StatusBar = "Gefundene Datensätze: " & Format$(lngRowCount - 1, "#,##0")
End Sub

VBA-Code  (Variante B)
Public Sub CountFilteredRows()
   Dim intRow As Long
   Dim intRowsAutoFilter As Long
   Dim rngActiveRange As Range
   Dim rngActiveCell As Range
   Set rngActiveRange = Selection
   Set rngActiveCell = ActiveCell
   intRowsAutoFilter = 0
   Selection.CurrentRegion.Select
   For intRow = 0 To Selection.CurrentRegion.Rows.Count - 1
      If Cells(intRow + rngActiveCell.Row, rngActiveCell.Column).Rows.Hidden = False Then
         intRowsAutoFilter = intRowsAutoFilter + 1
      End If
   Next intRow
   If intRow > 1 Then
      Application.StatusBar = "Gefundene Datensätze: " & Format$(intRowsAutoFilter - 1, "#,##0") & " von " & Format$(intRow - 1, "#,##0")
   Else
      Application.StatusBar = "Keine Liste an der aktuellen Position gefunden"
   End If
   rngActiveRange.Select
   rngActiveCell.Activate
   Set rngActiveCell = Nothing
   Set rngActiveRange = Nothing
End Sub

Prozeduraufruf in VBA
[Call] CountFilteredRows

[7] Anzahl Zellen mit Kommentaren ausgeben

Zusammenfassung
Dieses kleine Beispiel zeigt, wie man die Anzahl Zellen mit Zellkommentaren erhält.

VBA-Code
Public Sub CountCellsWithComments()
   Dim rngActiveRange As Range
   Dim rngActiveCell As Range
   Set rngActiveRange = Selection
   Set rngActiveCell = ActiveCell

   On Error Resume Next
   ActiveSheet.UsedRange.SpecialCells(xlCellTypeComments).Select
   If Err = 1004 Then
      MsgBox "Es existieren keine Zellen mit Kommentaren.", vbInformation
   Else
      On Error GoTo 0
      MsgBox "Das Arbeitsblatt enthält " & Format$(Selection.Cells.Count, "#,##0") & " Zellen mit Kommentaren.", vbInformation
      rngActiveRange.Select
      rngActiveCell.Activate
   End If

   Set rngActiveCell = Nothing
   Set rngActiveRange = Nothing
End Sub

Prozeduraufruf in VBA
[Call] CountCellsWithComments

[8] ZÄHLENWENN über mehrere Tabellenblätter

Zusammenfassung
Die Excel-Funktion ZÄHLENWENN besitzt den Nachteil, dass sie nur Zellen berücksichtigt, die sich im gleichen Tabellenblatt wie die Zelle mit der Formel befinden. Möchten Sie Zellen berücksichtigen, die sich auf verschiedenen Blättern befinden, so hilft nur eine eigene VBA-Funktion.

VBA-Code
Private Function ZÄHLENWENN2(varSuche As Variant) As Long
   Dim objDummy As Object
   Dim rngRange As Range
   ZÄHLENWENN2 = 0
   For Each objDummy In ActiveWindow.SelectedSheets
      objDummy.Activate
      For Each rngRange In Selection.Areas
         ZÄHLENWENN2 = ZÄHLENWENN2 + WorksheetFunction.CountIf(rngRange, varSuche)
      Next
   Next
End Function

Funktionsaufruf in einer Zelle
Die Funktion kann aus technischen Gründen nicht in einer Zelle aufgerufen werden.

Funktionsaufruf in VBA
MsgBox ZÄHLENWENN2("Hallo")

[9] Zellwerte auf ihre Gültigkeit prüfen

Zusammenfassung
Wird bei einer Zelle eine Gültigkeitsregel definiert (Menü Daten/Gültigkeit) und dann in diese Zelle ein Wert eingegeben, so prüft die Gültigkeitsfunktion, ob der Zellinhalt erlaubt ist. Wird dagegen die Gültigkeitsregel erfasst nachdem bereits ein Zell-Wert eingegeben wurde, so wird die Gültigkeit nicht mehr geprüft. Dasselbe gilt für alle Zellen, deren Inhalte beispielsweise aus einer externen Datenquelle stammen.

Wenn Sie nun alle Zellen auf Gültigkeit überprüfen möchten, bevor zum Beispiel der Benutzer die Arbeitsmappe speichert, müssen die einzelnen Zellinhalte mittels VBA-Programm getestet werden. Die hier vorgestellte VBA-Prozedur testet alle Zellen mit Gültigkeitsregeln, ob die Zellwerte gültig sind (d.h. die Gültigkeitsregeln erfüllen).

VBA-Code
Public Sub ShowInvalidCells()
   Dim rngRange As Range
   Dim rngCell As Range
   Dim rngActiveRange As Range
   Dim rngActiveCell As Range

   Set rngActiveRange = Selection
   Set rngActiveCell = ActiveCell

   On Error Resume Next
   ActiveCell.SpecialCells(xlCellTypeAllValidation).Select
   If Err = 1004 Then
      MsgBox "Es existieren keine Zellen mit Gültigkeitsprüfungen.", vbInformation
      Exit Sub
   End If
   On Error GoTo 0
   Set rngRange = Selection
   For Each rngCell In rngRange
      If rngCell.Validation.Value = False Then
         MsgBox "Gültigkeit von Zelle " & rngCell.Address & " ist nicht erfüllt.", vbInformation
      End If
   Next

   rngActiveRange.Select
   rngActiveCell.Activate

   Set rngCell = Nothing
   Set rngRange = Nothing
   Set rngActiveRange = Nothing
   Set rngActiveCell = Nothing
End Sub

Prozeduraufruf in VBA
[Call] ShowInvalidCells

[10] Dokument-Eigenschaften der Arbeitsmappendatei auflisten

Zusammenfassung
Eine Excel-Arbeitsmappe besitzt nicht nur ihre Excel-spezifischen Eigenschaften sondern wie jedes Office-Dokument auch zahlreiche weitere Dokument-Eigenschaften. Der hier vorgestellte Programmcode ermittelt sämtliche für eine Exceldatei verfügbaren Eigenschaften und listet diese übersichtlich in einem neu angelegten Tabellenblatt auf.

VBA-Code
Public Sub ShowDocumentProperties()
   Dim intCounter As Integer
   Dim varObject As Office.DocumentProperties
   Dim wksSheet As Worksheet

   On Error Resume Next

   Set varObject = ActiveWorkbook.BuiltinDocumentProperties
   Set wksSheet = ActiveWorkbook.Worksheets.Add
   With wksSheet
      .Name = "Dokument-Eigenschaften"
      .Range("A1").Value = "Eigenschaft"
      .Range("B1").Value = "Wert"
      .Range("C1").Value = "Typ"
      .Range("A1:C1").Font.Bold = True
      For intCounter = 1 To varObject.Count
         Cells(intCounter + 1, 1).Value = varObject(intCounter).Name
         Cells(intCounter + 1, 2).Value = varObject(intCounter).Value
         If Err Then
            Cells(intCounter + 1, 2).Value = "(Nicht verfügbar)"
            Err.Clear
         End If
         Cells(intCounter + 1, 3).Value = varObject(intCounter).Type
      Next intCounter
   End With

   wksSheet.Columns("A:C").Select
   Application.Selection.Columns.AutoFit
   wksSheet.Range("A1").Select
   Set wksSheet = Nothing
   Set varObject = Nothing
End Sub

Prozeduraufruf in VBA
[Call] ShowDocumentProperties

[11] AutoFilter-Ergebnisdatensätze in neues Tabellenblatt kopieren

Zusammenfassung
Die vom AutoFilter ermittelten Datensätze lassen sich mit VBA leicht in ein neues Arbeitsblatt kopieren.

VBA-Code
Public Sub CopyFilterResultToNewSheet
   Worksheets("Tabelle1").Range("A1").AutoFilter Field:=1, Criteria1:="Staubsauger"
   Range("A1").CurrentRegion.Copy
   Worksheets.Add After:=Worksheets(Worksheets.Count)
   ActiveSheet.Paste
   Worksheets("Tabelle1").Range("A1").AutoFilter
   Application.CutCopyMode = False
End Sub

Prozeduraufruf in VBA
[Call] CopyFilterResultToNewSheet

[12] Zwei Zellbereiche miteinander vergleichen, ob sie identisch sind

Zusammenfassung
Beschreibung folgt...

VBA-Code
Public Sub CheckIfSame()
  Dim intZähler As Integer
  Dim intZähler2 As Integer
  Application.StatusBar = False
  For intZähler = Selection.Row To Selection.Rows.Count + Selection.Row - 1
    If IsNull(Range("A" & CStr(intZähler) & ":G" & CStr(intZähler)).Text) Then
     Exit For
    End If
  Next intZähler
  For intZähler2 = Selection.Column To Selection.Columns.Count + Selection.Column - 1
    If IsNull(Range(Left$(Cells(1, intZähler2).Address(False, False), Len(Cells(1, intZähler2).Address(False, False)) - 1) & CStr(Selection.Row) & ":" & Left$(Cells(1, intZähler2).Address(False, False), Len(Cells(1, intZähler2).Address(False, False)) - 1) & CStr(Selection.Rows.Count + Selection.Row - 1)).Text) Then
      Application.StatusBar = "Unterschied gefunden!   Zeile: " & CStr(intZähler) & ", Spalte: " & CStr(intZähler2)
      Exit For
    End If
  Next intZähler2
End Sub

Prozeduraufruf in VBA
[Call] CheckIfSame

[13] Ergebnis einer Matrix-Formel in Datenfeldvariable speichern

Zusammenfassung
Beschreibung folgt...

VBA-Code
Public Sub EvaluateArrayFormula()
   Dim varArray As Variant
   Dim intElemente1 As Integer
   Dim intElemente2 As Integer
   varArray = Application.Evaluate("MINVERSE(A1:C3)")
   If IsError(varArray) = True Then
      Select Case Application.Evaluate("ERROR.TYPE(MINVERSE(A1:C3))")
         Case 1
            MsgBox "Fehler #NULL! aufgetreten"
         Case 2
            MsgBox "Fehler #DIV/0! aufgetreten"
         Case 3
            MsgBox "Fehler #WERT! aufgetreten"
         Case 4
            MsgBox "Fehler #BEZUG! aufgetreten"
         Case 5
            MsgBox "Fehler #NAME? aufgetreten"
         Case 6
            MsgBox "Fehler #ZAHL! aufgetreten"
         Case 7
            MsgBox "Fehler #NV aufgetreten"
         Case Else
            MsgBox "Sonstiger Fehler aufgetreten"
      End Select
   Else
      For intElemente1 = 1 To UBound(varArray, 1)
         For intElemente2 = 1 To UBound(varArray, 2)
            MsgBox "Element " & intElemente1 & "," & intElemente2 & ": " & varArray(intElemente1, intElemente2)
         Next intElemente2
      Next intElemente1
   End If
End Sub

Prozeduraufruf in VBA
[Call] EvaluateArrayFormula

[14] Arbeitsblätter als Gruppe selektieren

Zusammenfassung
Nicht ganz intuitiv ist das Vorgehen, wenn man mehrere Blätter als Gruppe selektieren möchte. Die Select-Methode des Sheets-Objektes besitzt einen Parameter namens Replace, mit dem gesteuert wird, ob das selektierte Blatt der bestehenden Selektion hinzugefügt werden soll.

VBA-Code (Variante A)
Public Sub SelectSheetsAsGroup()
   Dim intCounter As Integer
   For intCounter = 1 To Sheets.Count
      Sheets(intCounter).Select False
   Next intCounter
End Sub

VBA-Code (Variante B)
Public Sub SelectSheetsAsGroup()
   Dim objSheet as Object
   For Each objSheet in Sheets
      objSheet.Select False
   Next
End Sub

Prozeduraufruf in VBA
[Call] SelectSheetsAsGroup

[15] Diagrammblätter als Gruppe selektieren

Zusammenfassung
Beschreibung folgt...

VBA-Code
Public Sub SelectChartSheetsAsGroup()
   Dim objSheet as Object
   For Each objSheet in Sheets
      If TypeName(objSheet) = "Chart" Then
         objSheet.Select False
      End If
   Next
End Sub

Prozeduraufruf in VBA
[Call] SelectChartSheetsAsGroup

[16] VBA-Prozedur in bestimmten Zeitabständen automatisch ausführen

Zusammenfassung
Beschreibung folgt...

VBA-Code
Sub ZeitFestlegen()
  c = True
  Zeitangabe = Time + TimeSerial(0, 0, 1)
  Application.OnTime Zeitangabe, "Eintragen"
End Sub

Sub Eintragen()
  Sheets("Tabelle2").Cells(1, 2).Value = Time
  If c = True Then ZeitFestlegen
End Sub

'Damit kann die Ausführung abgebrochen werden:
Sub NotStopp()
  c = False
End Sub

Prozeduraufruf in VBA
[Call] ZeitFestlegen

[17] Start- und Ende-Zellen von mehreren selektierten Bereichen auflisten

Zusammenfassung
Der nachstehende VBA-Programmcode ermittelt korrekt die Von-/Bis-Kalendertage der selektierten Bereiche. Es werden alle erlaubten Selektionsarten berücksichtigt, d.h. einzelne Zellen (z.B. 5.02.-5.02.), Zeilen (z.B. 5.02.-18.02.), Spalten (z.B. 5.02.-5.07.) und Blöcke (z.B. 5.02.-18.07.) sowie beliebige Kombinationen.

Die ermittelten Von-Tage werden in der Spalte AL, die Bis-Tage in Spalte AM aufgelistet. Da je nach Art und Anzahl der selektierten Bereiche die Anzahl Zeilen der Auflistung variiert, wird die Liste zuerst mittels der Anweisung "Range("AL10").CurrentRegion.Clear" gelöscht, damit nicht
alte Von-/Bis-Angaben der ehemaligen Selektion stehenbleiben. Die Prozedur wird bei mir automatisch vom Worksheets_SelectionChange-Ereignis des Arbeitsblattes aufgerufen, damit die Tage unmittelbar nach jeder Selektionsänderung neu aufgelistet werden.

VBA-Code
Public Sub GetSelectedDateRanges()
   Dim x As Variant
   Dim intRowsSelection As Integer
   Dim intRowsArea As Integer
   Range("AL10").CurrentRegion.Clear
   For Each x In Selection.Areas
      For intRowsArea = 0 To x.Rows.Count - 1
         Range("AL" & 10 + intRowsArea + intRowsSelection).Value = DateSerial(Cells(3, 2), _
            x.Row - 35 + intRowsArea, x.Column - 5)
         Range("AM" & 10 + intRowsArea + intRowsSelection).Value = DateSerial(Cells(3, 2), _
            x.Row - 35 + intRowsArea, x.Column + x.Columns.Count - 6)
      Next intRowsArea
      intRowsSelection = intRowsSelection + intRowsArea
   Next
End Sub

Prozeduraufruf in VBA
[Call] GetSelectedDateRanges

[18] Aktivierter Zellbearbeitungsmodus feststellen

Zusammenfassung
Dieses Codebeispiel zeigt, wie festgestellt werden kann, ob die direkte Zellbearbeitung aktiviert ist, d.h. ob der Inhalt einer Zelle gerade editiert wird.

VBA-Code
Public Sub CheckEditMode()
   Dim x As Integer
   Dim y As Integer
   Do
      For x = 1 To 50
         For y = 1 To 5000:DoEvents:Next y
         If Application.CommandBars("File").Controls("&Neu...").Enabled = True Then
            Application.StatusBar = "Normal"
         Else
            Application.StatusBar = "Bearbeiten"
         End If
      Next x
   Loop
End Sub

Prozeduraufruf in VBA
[Call] CheckEditMode

[19] Arbeitsblatt als GIF- oder JPEG-Datei exportieren

Zusammenfassung
Mit der Prozedur ExportWorksheetAsPicture wird der Inhalt des aktiven Tabellenblattes als Bilddatei im GIF-Format gespeichert.

VBA-Code
Public Sub ExportWorksheetAsPicture
   Dim chrPicture As Chart
   Dim strSheetName As String
   Application.ScreenUpdating = False
   strSheetName = ActiveSheet.Name
   ActiveSheet.Range(ActiveSheet.UsedRange.Address).CopyPicture Appearance:=xlScreen, Format:=xlPicture
   Set chrPicture = Charts.Add
   chrPicture.Paste
   chrPicture.Export "C:\Temp\" & strSheetName & ".gif"  'oder ".jpg"
   Application.DisplayAlerts = False
   chrPicture.Delete
   Application.DisplayAlerts = True
   Set chrPicture = Nothing
   Application.ScreenUpdating = True
End Sub

[20] Zellbereich als GIF- oder JPEG-Datei exportieren

Zusammenfassung
Beschreibung folgt...

VBA-Code

Public Sub ExportWorksheetAsPicture
   Dim chrPicture As Chart
   Dim strSheetName As String
   Application.ScreenUpdating = False
   strSheetName = ActiveSheet.Name
   ActiveSheet.Range(ActiveSheet.UsedRange.Address).CopyPicture Appearance:=xlScreen, Format:=xlPicture
   Set chrPicture = Charts.Add
   chrPicture.Paste
   chrPicture.Export "C:\Temp\" & strSheetName & ".gif"   'oder ".jpg"
   Application.DisplayAlerts = False
   chrPicture.Delete
   Application.DisplayAlerts = True
   Set chrPicture = Nothing
   Application.ScreenUpdating = True
End Sub

[21] Datensätze aus Datenbank in einen Zellbereich füllen

Zusammenfassung
Beschreibung folgt...

VBA-Code

Range("A1:" & Left$(Cells(1, rsArchive.Fields.Count).Address(False, False), Len(Cells(1, rsArchive.Fields.Count).Address(False, False)) - 1) & rsArchive.RecordCount).Value = Application.Transpose(rsArchive.GetRows(rsArchive.RecordCount))

Range(Cells(1, 1), Cells(rsArchive.RecordCount, rsArchive.Fields.Count)).Value = Application.Transpose(rsArchive.GetRows(rsArchive.RecordCount))

[22] Druckbereich eines Tabellenblattes auf andere Tabellenblätter übernehmen

Zusammenfassung
In diesem Beispiel wird der Druckbereich von Tabelle1 auf Tabelle2 übernommen.

VBA-Code
Public Sub ApplyPrintArea
  Worksheets("Tabelle2").PageSetup.PrintArea = Worksheets("Tabelle1").PageSetup.PrintArea
End Sub

[23] Doppelklick öffnet den in der Zelle angegebenen Ordner im Windows Explorer

Zusammenfassung
Beschreibung folgt...

VBA-Code
Public Sub Auto_Open()
  Worksheets("Tabelle1").OnDoubleClick = "OpenExplorer"
End Sub

Public Sub Auto_Close()
  Worksheets("Tabelle1").OnDoubleClick = ""
End Sub

Public Sub OpenExplorer()
  Shell "Explorer " & Application.Caller, vbNormalFocus
End Sub

[24] Jahreskalender generieren

Zusammenfassung
Beschreibung folgt...

VBA-Code
Public Sub CreateCalendarOneYear()
  ActiveSheet.Range("A4").Formula = CDate("1.01.2002")
  ActiveSheet.Range("A4").AutoFill Destination:=ActiveSheet.Range("A4:L4"), Type:=xlFillMonths
  ActiveSheet.Range("A4:L4").AutoFill Destination:=ActiveSheet.Range("A4:L34"), Type:=xlFillDays
  If Year(ActiveSheet.Range("A4").Value) Mod 4 = 0 Then
    ActiveSheet.Range("B33:B34, D34, F34, I34, K34").Value = ""
  Else
    ActiveSheet.Range("B32:B34, D34, F34, I34, K34").Value = ""
  End If
End Sub

[25] Tastenkombination Strg+Unterbrechen abfangen und darauf reagieren

Zusammenfassung
Dieses Beispiel zeigt den Einsatz der Eigenschaft EnableCancelKey, mit der man die Unterbrechung eines laufenden Makros feststellen kann.

VBA-Code
Public Sub SampleProcedure()
  On Error GoTo errSampleProcedure
  Application.EnableCancelKey = xlErrorHandler
  Dim intCounter As Integer
  For intCounter = 1 To 10
    MsgBox intCounter
  Next intCounter
  Exit Sub
errSampleProcedure:
  If Err.Number = 18 Then
    MsgBox "Unterbrechen ist nicht gestattet!", vbExclamation
  End If
  Resume
End Sub

[26] Erstes Tabellenblatt aus einem anderen Papierschacht drucken

Zusammenfassung
Das Objektmodell von Microsoft Excel bietet leider keine Möglichkeit zum Festlegen des Papierschachts. Es gibt zwei Umgehungslösungen für dieses Problem, nachfolgend als Lösungsvariante A und B vorgestellt.

Lösungsvariante A
Wenn beispielsweise das erste Arbeitsblatt aus einen anderen Papierschacht als die restlichen Arbeitsblätter gedruckt werden soll, muss in der Windows-Systemsteuerung ein separater Drucker definiert werden, welcher einen anderen Schacht verwendet. Abgesehen vom Papierschacht sind alle Einstellungen identisch mit denjenigen des Standarddruckers.

Abbildung: Drucker "HP LaserJet 4M Plus" und "HP LaserJet 4M Plus (Schacht 2)"

Der Nachteil dieser Lösung ist, dass zuerst von Hand über die Windows-Systemsteuerung ein neuer Drucker definiert werden muss. Sie können die Arbeitsmappe daher nicht ohne weiteres auf anderen Arbeitsstationen ausdrucken. Zudem muss die Druckerbezeichnung, in obiger Abbildung "HP LaserJet 4M Plus (Schacht 2)", exakt mit der im VBA-Makro verwendeten Druckerbezeichnung übereinstimmen. Auch der verwendete Druckeranschluss (im Beispiel 'LPT1:') muss korrekt angegeben werden. Der Vorteil ist, dass nachdem der zusätzliche Drucker angelegt wurde, der VBA-Code fehlerfrei funktionieren wird.

VBA-Code (Lösungsvariante A)
Public Sub ChangePaperSourceAndPrint
  Dim strDrucker As String
  Dim intCounter As Integer
  'Momentan aktiver Drucker merken
  strDrucker = Application.ActivePrinter
  'Drucker mit der anderen Schacht-Einstellung aktivieren
  Application.ActivePrinter = "HP LaserJet 4M Plus (Schacht 2) auf LPT1:"
  'Erstes Arbeitsblatt ausdrucken
  Worksheets(1).PrintOut
  'Ursprünglicher Drucker wieder aktivieren
  Application.ActivePrinter = strDrucker
  'Restliche Arbeitblätter selektieren und ausdrucken
  For intCounter = 2 To Worksheets.Count
    Worksheets(intCounter).Select False
  Next intCounter
  ActiveWindow.SelectedSheets.PrintOut
  Worksheets(1).Select
End Sub

Lösungsvariante B
Anstatt einen zweiten Drucker zu definieren, können Sie den zu verwendenden Papierschacht zur Makro-Laufzeit einstellen. Da es wie erwähnt keine Eigenschaft oder Methode dafür gibt, muss der Papierschacht über das Druckereigenschaften-Dialogfenster eingestellt werden. Dies erfolgt durch das Senden von Tastenbefehlen an die Anwendung Excel.

Abbildung: Drucker-Eigenschaften mit Papierschacht-Auswahlfeld

Der Vorteil dieser Lösungsvariante B ist, dass kein zusätzlicher Drucker über die Windows-Systemsteuerung eingerichtet werden muss, d.h. die Mappe kann ohne weiteres auf anderen Arbeitsstationen ausgedruckt werden. Der Nachteil ist, dass der 'Weg' zur Papierschacht-Option auf dem Dialogfenster "Drucker-Eigenschaften" bekannt sein muss. Dieser Weg ist im VBA-Makro in Form von Tastenbefehlen programmiert. Sollte einmal ein anderer Drucker verwendet oder ein Update des Druckertreibers installiert werden, so kann es sein, dass die angegebenen Tastenbefehle nicht mehr funktionieren, weil sich die Papierschacht-Einstellung möglicherweise an einer anderen Stelle auf dem Drucker-Dialogfenster befindet.

VBA-Code (Lösungsvariante B)
Public Sub ChangePaperSourceAndPrint
  'Papierschacht auf 'Tray 1' einstellen
  SendKeys "%dd%e+{tab}{right 2}{tab 6}t{enter}{esc}", True
  'Erstes Arbeitsblatt ausdrucken
  Worksheets(1).PrintOut
  'Papierschacht auf 'Auto Select' einstellen
  SendKeys "%dd%e+{tab}{right 2}{tab 6}a{enter}{esc}", True
  'Restliche Arbeitblätter selektieren und ausdrucken
  For intCounter = 2 To Worksheets.Count
    Worksheets(intCounter).Select False
  Next intCounter
  ActiveWindow.SelectedSheets.PrintOut
  Worksheets(1).Select
End Sub

Hinweis
Bitte beachten Sie, dass der obige VBA-Code nicht unverändert übernommen werden kann. Die bei der SendKeys-Anweisung angegebenen Tastenbefehle müssen an das auf Ihrem System angezeigte Dialogfenster "Drucker-Eigenschaften" angepasst werden.

	Informationen zum Thema "Tastenbefehle senden"
	The eXpLorer: Senden von Tastenfolgen

[27] Häufigkeit-Funktion mit AutoFilter einsetzen

Zusammenfassung
Die Tabellenblatt-Funktion HÄUFIGKEIT berücksichtigt keine vom AutoFilter ausgeblendeten Zeilen, sprich nur das Filterergebnis. Die zu filternde Liste geht von Zelle A2 bis A10 (kann auch länger sein). In A1 steht die Spaltenüberschrift. Die Ergebnisbereiche stehen in C12:C14. Die von HÄUFIGKEIT gelieferte Ergebnismatrix wird in D12:D15 eingetragen.

VBA-Code
Public Sub HäufigkeitMitAutoFilter()
  Dim rngRows As Range
  Dim lngCounter As Long
  Dim strParameter As String
  Set rngRows = ActiveSheet.Range("A1").CurrentRegion.SpecialCells(xlVisible)
  If rngRows.Areas.Count > 1 Then
    For lngCounter = 2 To rngRows.Areas.Count
      If strParameter = "" Then
        strParameter = rngRows.Areas(lngCounter).Address
      Else
        strParameter = strParameter & "," & rngRows.Areas(lngCounter).Address
      End If
    Next lngCounter
  Else
    strParameter = rngRows.Offset(1, 0).Resize(rngRows.Rows.Count - 1, rngRows.Columns.Count).Address
  End If
  ActiveSheet.Range("D12:D15").FormulaArray = "=FREQUENCY((" & strParameter & "),C12:C14)"
End Sub

[28] Mit "Datei öffnen"-Dialog mehrere Arbeitsmappen öffnen

Zusammenfassung
In diesem Beispiel wird gezeigt, wie man im "Datei öffnen"-Dialogfenster mehrere Dateien selektieren und anschliessend 'auf einen Schlag' öffnen kann.

VBA-Code
Public Sub ChooseMultipleFiles()
  Dim intCounter As Integer
  Dim varFileNames As Variant
  varFileNames = Application.GetOpenFilename(MultiSelect:=True)
  intCounter = 1
  While intCounter <= UBound(varFileNames)
    Workbooks.Open varFileNames(intCounter)
    intCounter = intCounter + 1
  Wend
End Sub

[29] Bildobjekt in der Wiederholungszeile zentrieren

Zusammenfassung
Mit der hier vorgestellten VBA-Prozedur wird eine Grafik (ein Bildobjekt) in der Wiederholungszeile eingemittet. Das Makro setzt voraus, dass auf dem aktiven Tabellenblatt ein Bildobjekt existiert, das den Namen "Bild" besitzt. Bei Verwendung eines anderen Namens muss die letzte Codezeile entsprechend angepasst werden.

Da zum Zentrieren der Druckbereich benötigt wird, wird er, falls noch nicht festgelegt, automatisch im Makro festgelegt. Als Bereich wird dann der benutzte Zellbereich verwendet. Vertikale Seitenwechsel werden automatisch erkannt und berücksichtigt.

VBA-Code
Public Sub CenterPicture()
  Dim strPrintArea As String
  Dim dblPrintAreaWidth As Double
  With ActiveSheet
    If .PageSetup.PrintArea = "" Then
      'Druckbereich festlegen
      .PageSetup.PrintArea = .UsedRange.Address
    End If
    strPrintArea = .PageSetup.PrintArea
    If .VPageBreaks.Count = 0 Then
      'Breite des Druckbereiches berechnen
      dblPrintAreaWidth = _
        .Range(Left$(strPrintArea, InStr(strPrintArea, ":") - 1)).Left + _
        .Range(Mid$(strPrintArea, InStr(strPrintArea, ":") + 1)).Left + _
        .Range(Mid$(strPrintArea, InStr(strPrintArea, ":") + 1)).Width
    Else
      'Breite der ersten Seite des Druckbereiches berechnen
      dblPrintAreaWidth = _
        .Range(Left$(strPrintArea, InStr(strPrintArea, ":") - 1)).Left + _
        .Range(.VPageBreaks(1).Location.Address).Left
    End If
    'Bildobjekt auf der ersten Seite zentrieren
    .Shapes("Bild").Left = (dblPrintAreaWidth / 2) - (.Shapes("Bild").Width / 2)
  End With
End Sub

Hinweis
Bitte beachten Sie, dass im obigen Codebeispiel keine Laufzeitfehler abgefangen werden. Wenn das aktive Arbeitsblatt keine Tabelle ist, kein Bildobjekt existiert oder der Druckbereich nur eine einzelne Zelle gross ist, so treten diesbezügliche Fehlermeldungen auf.

[30] Gesamt-Inhaltsverzeichnis mit Seitenzahlen der Arbeitsblätter erstellen

Zusammenfassung
Microsoft Excel verfügt über keine Funktion, mit der man ein Inhaltsverzeichnis mit Seitenzahlen anlegen kann. Die Aufgabe der hier vorgestellten VBA-Prozedur ist es, ein Tabellenblatt mit einem Inhaltsverzeichnis zu erstellen, in welchem die Arbeitsblätter mit ihren Seitenzahlen aufgeführt sind. Die Prozedur kann beliebig oft hintereinander ausgeführt werden, da ein allfällig vorhandenes Inhaltsverzeichnis-Tabellenblatt durch das neue Inhaltsverzeichnis ersetzt wird.

Die erste Seite des ersten Tabellenblattes besitzt immer die Seitenzahl 1. Wenn dieses Tabellenblatt beispielsweise 5 Druckseiten umfasst, beginnt folglich das zweite Tabellenblatt auf Seite 6. Umfasst das zweite Blatt zum Beispiel 13 Seiten, so beginnt das dritte Tabellenblatt auf der Seite 19. Und so weiter.

VBA-Code
Public Sub CreateIndex()
  Dim intSheet As Integer
  Dim intSheetPages As Integer
  Dim intPreviousSheetPages As Integer
  Dim intRow As Integer
  Const intFirstPage As Integer = 1
  intRow = 3
  Application.ScreenUpdating = False
  With ActiveWorkbook
    If .Sheets(1).Name = "Inhaltsverzeichnis" Then
      'Allfällig vorhandenes Inhaltsverzeichnisblatt löschen
      Application.DisplayAlerts = False
      .Sheets(1).Delete
      Application.DisplayAlerts = True
    End If
    'Neues Tabellenblatt zuvorderst in die Mappe einfügen
    .Sheets.Add before:=.Sheets(1)
    With .Sheets(1)
      'Titel und Überschriften eintragen
      .Name = "Inhaltsverzeichnis"
      .Range("A1").Value = "Inhaltsverzeichnis"
      .Range("A1").Font.Bold = True
      .Range("A1").Font.Size = .Range("A1").Font.Size + 2
      .Range("A3").Value = "Arbeitsblatt"
      .Range("B3").Value = "Seite"
      .Range("A3:B3").Font.Bold = True
    End With
    For intSheet = 2 To .Sheets.Count '2 damit Inhaltsverzeichnisblatt nicht im Inhaltsverzeichnis aufgeführt wird
      If .Sheets(intSheet).Visible = True Then
        intRow = intRow + 1
        'Seitenanzahl des aktiven Arbeitsblattes abfragen
        .Sheets(intSheet).Activate
        intSheetPages = ExecuteExcel4Macro("GET.DOCUMENT(50)")
        With .Sheets(1)
          'Zahlenformat "Text" einstellen, damit ein Blattname z.B. "2003" nicht rechtsbündig dargestellt wird
          .Range("A" & CStr(intRow)).NumberFormat = "@"
          .Range("A" & CStr(intRow)).Value = ActiveWorkbook.Sheets(intSheet).Name
          If intSheet = 2 Then
            'Das erste Tabellenblatt im Inhaltsverzeichnis beginnt auf Seite 1
            .Range("B" & CStr(intRow)).Value = intFirstPage
          Else
            'Erste Seite der weiteren Tabellenblätter berechnen
            'Formel: Erste Seite des aktuellen Blattes = Erste Seite des vorherigen Blattes + Anzahl Seiten des vorherigen
            'Blattes
            .Range("B" & CStr(intRow)).Value = .Range("B" & CStr(intRow - 1)).Value + intPreviousSheetPages
          End If
          'Seitenanzahl zwischenspeichern
          intPreviousSheetPages = intSheetPages
        End With
      End If
    Next intSheet
    .Sheets(1).Activate
    .Sheets(1).Range("A1:B1").EntireColumn.AutoFit
  End With
  Application.ScreenUpdating = True
End Sub

[31] Steuerelemente zur Laufzeit einem Benutzerformular inkl. Ereignisprozedur hinzufügen

Zusammenfassung
Das Hinzufügen eines Benutzerformular-Steuerelementes zur Laufzeit ist schnell erledigt, da man das neue Steuerelement ganz einfach mit "<UserForm>.Controls.Add [...]" erstellt. Schwieriger wird es, wenn das neue Steuerelement auf Ereignisse reagieren soll, beispielsweise auf das Klick-Ereignis. Dieses Codebeispiel zeigt, was es alles dazu braucht.

Bei jedem Klick auf die Schaltfläche "cmdAddControls" wird jeweils ein CommandButton, eine ComboBox und ein OptionButton dem Formular hinzugefügt und nebeneinander angeordnet. Aus technischer Sicht wird ein neu hinzugefügtes Control nicht nur als neues UserForm-Control erstellt sondern zusätzlich eine Instanz derjenigen Klasse anlegt, in der sich der Event Handler für den Controltyp 'OptionButton' befindet. Beispielsweise wird für jeden neuen OptionButton eine Instanz der Klasse clsOptionButton angelegt (Set objNewOPT = New clsOptionButton). Mit "Public WithEvents objOptionButton As MSForms.OptionButton" im Klassenmodul werden die Ereignisse der OptionButtons abgefangen und im Klassenmodul verarbeitet (z.B. mit der Click-Ereignisprozedur).

Vorbereitung
- UserForm "frmDialog" hinzufügen (Width 350 Pts, Height 300 Pts)
- CommandButton "cmdAddControls" hinzufügen (rechts oben auf "frmDialog" anordnen)
- Klassenmodul "clsButton" hinzufügen
- Klassenmodul "clsComboBox" hinzufügen
- Klassenmodul "clsOptionButton" hinzufügen

VBA-Code
'Deklarationsbereich der UserForm frmDialog
Public objEvents As New Collection

'Codebereich der UserForm frmDialog
Private Sub cmdAddControls_Click()
  Static lngY As Long
  Static intControl As Integer
  Dim objNewCMD As clsButton
  Dim objNewCBO As clsComboBox
  Dim objNewOPT As clsOptionButton
  intControl = intControl + 1
  Set objNewCMD = New clsButton
  Set objNewCBO = New clsComboBox
  Set objNewOPT = New clsOptionButton
  Set objNewCMD.objButton = frmDialog.Controls.Add _
    ("Forms.CommandButton.1", "cmdButton" & intControl)
  Set objNewCBO.objComboBox = frmDialog.Controls.Add _
    ("Forms.ComboBox.1", "cboComboBox" & intControl)
  Set objNewOPT.objOptionButton = frmDialog.Controls.Add _
    ("Forms.OptionButton.1", "optOptionButton" & intControl)
  lngY = lngY + 30
  With objNewCMD.objButton
    .Top = lngY
    .Left = 10
    .Width = 100
    .Height = 20
    .Caption = "Schaltfläche " & CStr(intControl)
  End With
  With objNewCBO.objComboBox
    .Top = lngY
    .Left = 130
    .Width = 100
    .AddItem "Kombinationsfeld " & CStr(intControl)
    .AddItem "Eintrag 1"
    .AddItem "Eintrag 2"
  End With
  With objNewOPT.objOptionButton
    .Top = lngY
    .Left = 250
    .Width = 100
    .Height = 20
    .Caption = "Optionsfeld " & CStr(intControl)
  End With
  objEvents.Add objNewCMD
  objEvents.Add objNewCBO
  objEvents.Add objNewOPT
End Sub

'Deklarationsbereich der Klasse clsButton
Public WithEvents objButton As MSForms.CommandButton

'Codebereich der Klasse clsButton
Private Sub objButton_Click()
  MsgBox objButton.Name & " / " & objButton.Caption
End Sub

'Deklarationsbereich der Klasse clsComboBox
Public WithEvents objComboBox As MSForms.ComboBox

'Codebereich der Klasse clsCheckBox
Private Sub objComboBox_Click()
  MsgBox objComboBox.Name & " / " & objComboBox.Text
End Sub

'Deklarationsbereich der Klasse clsOptionButton
Public WithEvents objOptionButton As MSForms.OptionButton

'Codebereich der Klasse clsOptionButton
Private Sub objOptionButton_Click()
  MsgBox objOptionButton.Name & " / " & objOptionButton.Caption
End Sub

[32] Benutzerdefinierte Excel-Funktion über eine Symbolleisten-Schaltfläche aufrufen

Zusammenfassung
Das Anlegen der Symbolleiste mit der Schaltfläche für die Funktion ist schnell erledigt. Auch die benutzerdefinierte Funktion muss man gewöhnlich nicht speziell anpassen, damit sie über eine Schaltfläche eingefügt werden kann. Das Schwierigste ist die Prozedur, mit der die Funktion in die Zelle eingetragen wird, die automatisch den korrekten Zellbereich selektiert und die Texteinfügemarke an die richtige Stelle in der Funktionsklammer setzt bzw. die Bereichsadresse markiert. Ich habe ein kleines exemplarisches Beispiel für eine eigene AutoSumme-Funktion geschrieben.

VBA-Code
'Modul "Diese Arbeitsmappe"
'Beim Öffnen der Mappe eine neue Symbolleiste mit einer Schaltfläche anlegen
Private Sub Workbook_Open()
  Dim objCommandBar As CommandBar
  Dim objControl As CommandBarControl
  Set objCommandBar = Application.CommandBars.Add (Name:="MeineFunktion", Temporary:=True)
  With objCommandBar
    Set objControl = .Controls.Add(msoControlButton)
    With objControl
      .Caption = "MeineSumme"
      .Style = msoButtonIconAndCaption
      .FaceId = 226
      .OnAction = "InsertMeineSumme"
      .Visible = True
    End With
    Set objControl = Nothing
    .Visible = True
  End With
  Set objCommandBar = Nothing
End Sub

'Modul "Diese Arbeitsmappe"
'Beim Schliessen der Mappe die Symbolleiste löschen
Private Sub Workbook_BeforeClose(Cancel As Boolean)
  On Error Resume Next
  Application.CommandBars("MeineFunktion").Delete
  On Error GoTo 0
End Sub

'Codemodul
'Programmcode der benutzerdefinierten Funktion "MeineSumme"
Public Function MeineSumme(ByVal Bereich As Range) As Double
  Dim lngCell As Long
  For lngCell = 1 To Bereich.Cells.Count
    MeineSumme = MeineSumme + Bereich(lngCell)
  Next lngCell
End Function

'Codemodul
'Benutzerdefinierte Funktion als Formel in Zelle eintragen
Public Sub InsertMeineSumme()
  Dim rngCell As Range
  Dim strSumRange As String
  On Error GoTo ErrorHandler
  If TypeName(Selection) <> "Range" Then
    'Anderes Objekt als Zelle selektiert (z.B. Bild oder Diagramm)
    Exit Sub
  End If
  If Selection.Cells.Count > 1 Or Selection.Row = 1 Then
    'Mehr als eine Zelle selektiert oder Zelle auf Zeile 1 selektiert
    Exit Sub
  End If
  With Selection
    If IsEmpty(.Offset(-1, 0)) Or Not IsNumeric(.Offset(-1, 0)) Then
      'Zelle oberhalb ist leer oder enthält keine Zahl
      .Formula = "=MeineSumme()"
      'Eingabecursor in die Funktionsklammer setzen
      SendKeys "{F2}{left}"
    Else
      Do
        'Solange den Bereich nach oben erweitern, bis eine leere Zelle kommt,
        'eine Zelle keinen numerischen Wert enthält oder die erste Zeile erreicht ist
        If rngCell Is Nothing Then
          Set rngCell = .Offset(-1, 0)
        Else
          Set rngCell = rngCell.Offset(-1, 0)
        End If
        If rngCell.Row = 1 Or IsEmpty(rngCell) Or Not IsNumeric(rngCell.Value) Then
          strSumRange = Range(Cells(rngCell.Row, .Column), Cells(.Row - 1, .Column)).Address(False, False)
          Exit Do
        End If
      Loop
      .Formula = "=MeineSumme(" & strSumRange & ")"
      'Bereichsadresse in der Funktionsklammer markieren
      SendKeys "{F2}{left}+{left " & CStr(Len(strSumRange)) & "}"
      Set rngCell = Nothing
    End If
  End With
  Exit Sub
ErrorHandler:
  If Err.Number <> 0 Then
    'Bei Laufzeitfehler "#BEZUG!" in Zelle eintragen
    Selection.Formula = CVErr(xlErrRef)
  End If
End Sub

[33] Prüfen, ob die Zellinhalte von zwei Zellbereichen identisch ist

Zusammenfassung
Mit dieser benutzerdefinierten Tabellenblatt-Funktion RowsEqual können Sie herausfinden, ob zwei gleich grosse Zellbereiche einen identischen Inhalt besitzen. Die Funktion nimmt zwei Zellbereiche entgegen und liefert WAHR, wenn alle Zellinhalte gleich sind oder FALSCH, wenn der Inhalt irgend einer Zelle nicht gleich wie die entsprechende Zelle des anderen Zellbereiches ist. Wenn kein Zellbereich übergeben wird, liefert die Funktion "#BEZUG!". Wenn die beiden Zellbereiche nicht gleich gross sind bzw. der erste Bereich grösser als der zweite ist, wird "#WERT!" zurückgegeben.

VBA-Code
Public Function RowsEqual(Row1, Row2)
  Dim i As Integer, j As Integer
  Dim arr1 As Variant, arr2 As Variant
  'Check to see that input rows are arrays or multicell ranges
  If (IsArray(Row1) And IsArray(Row2)) Then
    'Convert input ranges to arrays
    arr1 = Row1
    arr2 = Row2
    'Loop to see if all elements are the same
    For i = LBound(arr1) To UBound(arr1)
      For j = LBound(arr2) To UBound(arr2, 2)
        If Not (arr1(i, j) = arr2(i, j)) Then
          RowsEqual = False
          Exit Function
        End If
      Next
    Next
    RowsEqual = True
  Else
    RowsEqual = CVEff(2024)
  End If
End Function

Aufruf als Zellformel
=RowsEqual(A1:E1;A2:E2)    'Vergleicht den Zellbereich A1:E5 mit A2:E2
=RowsEqual((A1:C1;E1);(A2:C2;E2))    'Vergleicht die Zellen von Spalte A, B, C und E der ersten Zeile mit der zweiten Zeile

Copyright-Hinweis
Diese Funktion wurde ursprünglich von Alan Beban entwickelt.

[34] Screen Shot eines Benutzerformulares erstellen und in die Zwischenablage ablegen

Zusammenfassung
Von Hand kann man einen Screen Shot eines geöffneten Benutzerformulares (UserForm) erzeugen, indem man die Tastenkombination Strg+Druck (Print Screen) drückt. Mit einem VBA-Programm geht das nicht ganz so einfach, weil es dafür weder eine entsprechende Funktion gibt noch die Tastenkombination simuliert werden kann (z.B. mittels SendKeys). Mit dem hier vorgestellten Programmcode lässt sich dies jedoch erledigen, wobei allerdings eine ganze Reihe API-Funktionen benötigt werden.

Kopieren Sie den VBA-Code in ein Codemodul. Fügen Sie dem VBA-Projekt anschliessend ein Benutzerformular hinzu, von welchem Sie einen Screen Shot erstellen wollen.

VBA-Code
Type RECT_Type
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type

Declare Function GetActiveWindow Lib "User32" () As Long
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Sub GetWindowRect Lib "User32" (ByVal Hwnd As Long, lpRect As RECT_Type)
Declare Function GetDC Lib "User32" (ByVal Hwnd As Long) As Long
Declare Function CreateCompatibleDC Lib "Gdi32" (ByVal hdc As Long) As Long
Declare Function CreateCompatibleBitmap Lib "Gdi32" (ByVal hdc As Long, ByVal nWidth As Long, _
  ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "Gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function BitBlt Lib "Gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
  ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
  ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Declare Function OpenClipboard Lib "User32" (ByVal Hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function ReleaseDC Lib "User32" (ByVal Hwnd As Long, ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "Gdi32" (ByVal hdc As Long) As Long

Global Const SRCCOPY = &HCC0020
Global Const CF_BITMAP = 2

Public Sub UserFormScreenShot()
  Dim FormHwnd As Long
  Dim DeskHwnd As Long
  Dim hdc As Long
  Dim hdcMem As Long
  Dim rect As RECT_Type
  Dim junk As Long
  Dim fwidth As Long
  Dim fheight As Long
  Dim hBitmap As Long
  DeskHwnd = GetDesktopWindow()
  FormHwnd = GetActiveWindow()
  Call GetWindowRect(FormHwnd, rect)
  fwidth = rect.right - rect.left
  fheight = rect.bottom - rect.top
  hdc = GetDC(DeskHwnd)
  hdcMem = CreateCompatibleDC(hdc)
  hBitmap = CreateCompatibleBitmap(hdc, fwidth, fheight)
  If hBitmap <> 0 Then
    junk = SelectObject(hdcMem, hBitmap)
    junk = BitBlt(hdcMem, 0, 0, fwidth, fheight, hdc, rect.left, rect.top, SRCCOPY)
    junk = OpenClipboard(DeskHwnd)
    junk = EmptyClipboard()
    junk = SetClipboardData(CF_BITMAP, hBitmap)
    junk = CloseClipboard()
  End If
  junk = DeleteDC(hdcMem)
  junk = ReleaseDC(DeskHwnd, hdc)
End Sub

Prozeduraufruf in VBA
Private Sub CommandButton1_Click()
  Me.Repaint
  Call UserFormScreenShot
End Sub

Hinweis
Wenn UserFormScreenShot, wie im obigen Prozeduraufruf gezeigt, beispielsweise mit einer Schaltfläche auf dem Benutzerformular aufgerufen wird, muss zuerst die Formularanzeige aktualisiert werden. Dies wird anhand "Me.Repaint" vorgenommen. Anderenfalls erscheint die Schaltfläche im Screen Shot in gedrücktem Zustand.

Weitere Informationen The SOSCQ Page - Codebeispiele: Screenshot eines Benutzerformulares in die Zwischenablage kopieren

[35] Änderung des Formates einer Zelle unterbinden

Zusammenfassung
Es gibt in Microsoft Excel keine Möglichkeit um zu verhindern, dass ein Benutzer die Formatierung einer Zelle verändert (beispielsweise Schriftgrad oder Hintergrundfarbe). Man könnte höchstens die Zelle sperren und dann den Blattschutz aktivieren. Dadurch kann aber auch der Inhalt der Zelle nicht mehr geändert werden. Das folgende Codebeispiel zeigt, wie man die Änderung der Formatierung unterbindet und trotzdem die Bearbeitung des Zellinhaltes weiterhin möglich ist. Damit der Programmcode funktioniert, müssen Sie für die zu "sperrende" Zelle eine Formatvorlage erstellen, welche die Formatierungseinstellungen dieser Zelle besitzt. Im Beispiel wird als Formatvorlagename "ZelleA1" verwendet.

Kopieren Sie den Programmcode in das Codemodul des Tabellenblattes, auf dem sich die zu "sperrende" Zelle befindet.

VBA-Code
Deklarationsbereich des Arbeitsblatt-Moduls
Public CellAddres As String

Ereignis-Prozedur des Arbeitsblattes
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
  If CellAddres = "$A$1" Then   'Tragen Sie hier die gewünschte Zelladresse ein
    Me.Range(CellAddres).Style = "ZelleA1"
  End If
  CellAddres = Target.Address
End Sub

[36] Erste sichtbare Zeile einer mit AutoFilter gefilterten Liste abfragen

Zusammenfassung
Da nur die sichtbaren Zeilen relevant sind, kann man SpecialCells(xlCellTypeVisible) zu Hilfe nehmen. Da der gefilterte Zellbereich ausgeblendete Zeilen enthält (bzw. enthalten kann), ist er in Areas unterteilt. Wenn Areas.Count = 1 ist, gibt es keine ausgeblendeten zwischen der Zeile mit den Spaltbeschriftungen und den Datenzeilen. Die erste sichtbare Zeile unterhalb der Beschriftungszeile ist somit die Datenzeile 1. Würde es eine oder mehrere ausgeblendete Zeilen geben, wäre Areas.Count > 1, da die Spaltenbeschriftungszeile ein Area ist und alle jeweils zusammenhängenden Datenzeilen je ein weiteres Area darstellen. Interessant ist jedoch nur das zweite Area, weil dieses die erste sichtbare Zeile enthält.

VBA-Code
Sub GetFirstVisibleRow()
  MsgBox _
    Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Areas( _
    Abs(Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Areas. _
    Count > 1) + 1).Cells(1, 3).Offset(Abs(Range("A1").CurrentRegion. _
    SpecialCells(xlCellTypeVisible).Areas.Count = 1), 0).Value
End Sub

[37] Warteschleife mit Zehntelsekunden-Auflösung und ohne Application.Wait

Zusammenfassung
Wenn in einem Excel VBA-Programm eine gewisse Zeit lang mit der Fortführung gewartet werden soll, so wird dazu gewöhnlich die Wait-Methode des Application-Objektes verwendet. Zum Beispiel kann man mit

  Application.Wait (Now + TimeValue("0:00:01")

die Programmausführung für eine Sekunde anhalten.

Die Nachteile von Wait sind jedoch, dass erstens während der Wartezeit Microsoft Excel blockiert ist, dass zweitens die kleinste Zeiteinheit eine Sekunde ist und dass drittens der Programmcode nicht mit anderen Microsoft Office-Programmen kompatibel ist (beispielsweise gibt es bei Microsoft Word keine Wait-Methode). Diese drei Nachteile kann man mittels einer eigenen Warteschleife umgehen.

VBA-Code
Public Sub WaitLoop(ByVal dblSeconds As Double)
  Dim dblWaitTimerStart As Double
  Dim dblWaitTimerLast As Double
  dblWaitTimerLast = 0
  dblWaitTimerStart = Timer
TryAgain:
  dblWaitTimerLast = Timer
  DoEvents
  If dblWaitTimerLast - dblWaitTimerStart <= dblSeconds Then
    Do
      If Timer - dblWaitTimerLast >= 0.1 Then
        Exit Do
      End If
      DoEvents
    Loop
    If Timer > dblWaitTimerLast Then
      GoTo TryAgain
    End If
  End If
  'Tatsächliche Dauer der Warteschleife ausgeben (nur zur Demo)
  MsgBox Timer - dblWaitTimerStart
End Sub

Prozeduraufruf in VBA (Beispiele)
WaitLoop 3.5     '3.5 Sekunden warten
WaitLoop 0.8     '0.8 Sekunden warten

Hinweis
Bitte beachten Sie, dass der obige VBA-Code auch in Microsoft Office für Macintosh funktioniert, jedoch als Wartedauer nur ganze Sekunden verwendet werden können. Anders als bei Windows liefert Timer auf Macintosh keine Bruchteile von Sekunden.

[38] Berechnungshilfe der Statuszeile nachprogrammieren (Summe, Mittelwert, Anzahl etc.)

Zusammenfassung
In der Statuszeile von Microsoft Excel gibt es die Möglichkeit, das Ergebnis der mathematischen Funktionen Summe, Mittelwert, Anzahl, Zählen, Min und Max anzeigen zu lassen. Dabei werden zur Berechnung die Werte aller selektierten Zellen berücksichtigt.

Leider kann man auf das angezeigte Ergebnis nicht zugreifen. Es bleibt daher nichts anderes übrig, als dieses Feature nachzuprogrammieren. Nachfolgend wird die Prozedur CalculateResults vorgestellt, mit der die benötigten Funktionsergebnisse berechnet werden. Die Ausgabe der Resultate ist in der Statusleiste oder in Zellen des verwendeten Tabellenblattes möglich (im Code gekennzeichnet als "Variante 1" und "Variante 2").

VBA-Code
Ereignis-Prozeduren des Arbeitsblattes
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  Call CalculateResults
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
  Call CalculateResults
End Sub

Prozedur im Arbeitsblatt-Modul
Private Sub CalculateResults()
  Dim rngRange As Range
  Dim strResult As String
  On Error Resume Next
  Application.EnableEvents = False
  If TypeName(Selection) = "Range" Then
    Set rngRange = ActiveSheet.Range(Selection.Address)

    'Variante 1: Anzeige in der Statuszeile
    With Application.WorksheetFunction
      strResult = "Summe: " & .Sum(rngRange)
      strResult = strResult & " Mittelwert: " & .Average(rngRange)
      If Err.Number <> 0 Then
        strResult = strResult & " Mittelwert: #NV"
        Err.Clear
      End If
      strResult = strResult & " Zählen: " & .Count(rngRange)
      strResult = strResult & " Anzahl: " & .CountA(rngRange)
      strResult = strResult & " Min: " & .Min(rngRange)
      strResult = strResult & " Max: " & .Max(rngRange)
      Application.StatusBar = strResult
    End With

    'Variante 2: Anzeige im Tabellenblatt
    With Application.WorksheetFunction
      ActiveSheet.Range("A1").Value = "Summe: " & .Sum(rngRange)
      ActiveSheet.Range("A2").Value = "Mittelwert: " & .Average(rngRange)
      If Err.Number <> 0 Then
        ActiveSheet.Range("A2").Value = "Mittelwert: #NV"
        Err.Clear
      End If
      ActiveSheet.Range("A3").Value = "Zählen: " & .Count(rngRange)
      ActiveSheet.Range("A4").Value = "Anzahl: " & .CountA(rngRange)
      ActiveSheet.Range("A5").Value = "Min: " & .Min(rngRange)
      ActiveSheet.Range("A6").Value = "Max: " & .Max(rngRange)
    End With

    Set rngRange = Nothing
  End If
  Application.EnableEvents = True
End Sub

[39] Druckbereich unter Berücksichtigung von vorhandenen AutoFormen festlegen

Zusammenfassung
Wenn man mit VBA den Druckbereich eines Tabellenblattes festlegen möchte, verwendet man gewöhnlich die UsedRange-Eigenschaft des Tabellenblattes, welche den benutzten Zellbereich darstellt. Das funktioniert ohne Probleme, so lange das Blatt keine Objekte enthält, die sich ganz oder teilweise ausserhalb des benutzten Zellbereiches befinden.

Diese Prozedur ermittelt den Druckbereich unter Berücksichtigung aller Objekte wie AutoFormen, Diagramme, Formular-Steuerelemente, ActiveX-Steuerelemente, eingebettete Dokumente und dergleichen.

Hinweis
Bitte beachten Sie, dass für die obere linke Zelle des Druckbereiches standardmässig die Zelle A1 verwendet wird.

VBA-Code
Public Sub SetPrintArea()
  Dim rngPrintArea As Range
  Dim rngRangeCheck As Range
  Dim intCounter As Integer
  'Ausgangszelle des Druckbereiches setzen
  Set rngPrintArea = ActiveSheet.Range("A1")
  If ActiveSheet.Shapes.Count > 0 Then
    'Alle Objekte nacheinander verarbeiten
    For intCounter = 1 To ActiveSheet.Shapes.Count
      If ActiveSheet.Shapes(intCounter).Type <> msoComment Then    'Kommentarobjekte ignorieren
        'Überprüfen, ob die Zelle der unteren rechten Ecke des Objektes innerhalb des momentanen Druckbereiches liegt
        Set rngRangeCheck = Application.Intersect(ActiveSheet.Range(rngPrintArea.Address), ActiveSheet.Shapes(intCounter).BottomRightCell)
        If rngRangeCheck Is Nothing Then
          'Objekt liegt ausserhalb, daher Druckbereich vergrössern
          Set rngPrintArea = ActiveSheet.Range("A1:" & ActiveSheet.Shapes(intCounter).BottomRightCell.Address)
        End If
      End If
    Next intCounter
  End If
  'Ermittelter Zellbereich als Druckbereich verwenden
  ActiveSheet.PageSetup.PrintArea = rngPrintArea.Address
  Set rngRangeCheck = Nothing
  Set rngPrintArea = Nothing
End Sub

[40] Selektierter Zellbereich als Textdatei exportieren

Zusammenfassung
Excel does not have a menu command to export data automatically to a text file such that the text file is exported with both quotation marks and commas as delimiters. For example, there is no command to automatically create a text file that contains the following:

"Text1","Text2","Text3"

However, you can create this functionality in Excel by using a VBA macro. This file format is commonly seen when importing text data in such applications as Microsoft Office Access 2003 and Microsoft Office Word 2003.

You can use the Print statement in a VBA macro, such as the following one, to export a text file with both quotation marks and commas as the delimiters. For the procedure to function properly, you must select the cells that contain your data before you run it.

VBA-Code
Public Sub QuoteCommaExport()
  Dim DestFile As String
  Dim FileNum As Integer
  Dim ColumnCount As Integer
  Dim RowCount As Integer
  DestFile = InputBox("Bitte Dateiname eingeben (inkl. Pfad):", "Exportieren")
  FileNum = FreeFile()
  On Error Resume Next
  Open DestFile For Output As #FileNum
  If Err.Number <> 0 Then
    MsgBox "Fehler beim Öffnen der Datei " & DestFile, vbExclamation
    Exit Sub
  End If
  On Error GoTo 0
  For RowCount = 1 To Selection.Rows.Count
    For ColumnCount = 1 To Selection.Columns.Count
      Print #FileNum, """" & Selection.Cells(RowCount, ColumnCount).Text & """";
      If ColumnCount = Selection.Columns.Count Then
        Print #FileNum,
      Else
        Print #FileNum, ",";
      End If
    Next ColumnCount
  Next RowCount
  Close #FileNum
End Sub

[41] Daten in zweispaltige Combobox einfüllen

Zusammenfassung
Gelegentlich liest man in Foren und Newsgroup die Frage, wie man eine Combobox oder eine Listbox mehrspaltig machen kann. Hier ein Beispiel, wie man die in einer Arbeitsmappe vorhandenen Formatvorlagen in eine Combobox zweispaltig einfüllen kann.

VBA-Code
Public Sub FillCombobox()
  Dim objStyle As Style
  Dim intStyles As Integer
  'Zweidimensionales Array für die zwei Spalten der Combobox
  ReDim aItems(0 To 1, 0 To ActiveWorkbook.Styles.Count - 1)
  'Formatvorlagenamen in das Array einfüllen
  For Each objStyle In ActiveWorkbook.Styles
    aItems(0, intStyles) = objStyle.NameLocal
    aItems(1, intStyles) = objStyle.Name
    intStyles = intStyles + 1
  Next
  'Array der Combobox zuweisen
  ComboBox1.Column = aItems
End Sub

[42] Nur Eingabe von Buchstaben und Ziffern in Textbox zulassen

Zusammenfassung
Dieses Beispiel zeigt, wie man verhindern kann, dass ein Benutzer andere Zeichen als Buchstaben und Ziffern in eine Textbox eingibt. Drückt man eine andere Taste als die Ziffern 0 bis 9, Buchstaben a bis z und Buchstaben A bis Z, so erscheint eine Hinweismeldung, und das Zeichen der gedrückten Taste wird nicht angenommen.

Der Code funktioniert sowohl für eine Textbox auf einem Benutzerformular also für eine in ein Arbeitsblatt eingebettete Textbox.

VBA-Code
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
  If Chr$(KeyAscii) Like "[0-9,a-z,A-Z]" = False Then
    MsgBox "Es dürfen nur Buchstaben und Ziffern eingegeben werden.", vbInformation
    KeyAscii = 0
  End If
End Sub

[43] Ausführung einer mit OnTime geplanten Prozedur verhindern

Zusammenfassung
Mit OnTime kann man komfortabel den Ausführungszeitpunkt einer Prozedur planen. Die Prozedur wird dann zu der anhand von EarliestTime angegebenen Zeit ausgeführt. Das Problem ist, dass die Prozedur - ist sie einmal geplant - auch dann aufgerufen wird, wenn die Arbeitsmappe, in der sich der Prozedurcode befindet, inzwischen geschlossen wurde. Damit die geschlossene Mappe nicht automatisch geöffnet und die enthaltene Prozedur ausgeführt wird, muss man den geplanten Zeitpunkt explizit löschen. Dies erfolgt anhand des Schedule-Parameters.

VBA-Code
Dim varTime As Variant

Sub SetTimer()
  varTime = Now + TimeValue("0:00:30")
  Application.OnTime EarliestTime:=varTime, Procedure:="DoIt"
End Sub

Sub KillTimer()
  Application.OnTime EarliestTime:=varTime, Procedure:="DoIt", , Schedule:=False
End Sub

Sub DoIt()
  MsgBox "Hallo OnTime!", vbInformation
End Sub

Prozedur testen
Führen Sie die Prozedur SetTimer aus. Nach 30 Sekunden wird automatisch die Prozedur DoIt aufgerufen. Wenn Sie vor Ablauf der 30 Sekunden die Prozedur KillTimer ausführen, wird DoIt nicht aufgerufen.

[44] Auf Taste warten und gedrückte Taste abfragen

Zusammenfassung
Mit der API-Funktion GetKeyState kann der (Gedrückt-)Status einer beliebigen Taste abgefragt werden. Baut man diese Abfrage in eine Programmschleife ein, so kann man elegant die Codeausführung so lange "anhalten", bis der Benutzer eine Taste drückt. Dabei kann man zudem auswerten, welche Taste gedrückt wurde und entsprechend darauf reagieren.

Das Codebeispiel wartet so lange, bis die Taste Enter, A, a, B oder b gedrückt wird. Anstelle von "Call SubFuerEnter", "Call SubFuerA" und "Call SubFuerB" können Sie eigene Prozeduren aufrufen.

VBA-Code
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

Sub WaitForKey()
  Dim strKey As String
  strKey = ""
  Do
    If Abs(GetKeyState(13) < 0) Then
      strKey = "Enter"
      Exit Do
    End If
    If Abs(GetKeyState(65) < 0) Then
      strKey = "A"
      Exit Do
    End If
    If Abs(GetKeyState(66) < 0) Then
      strKey = "B"
      Exit Do
    End If
    DoEvents
  Loop
  Select Case strKey
    Case "Enter"
      'Enter-Taste wurde gedrückt
      'z.B. "Call SubFuerEnter"
    Case "A"
      'Taste 'A' oder 'a' wurde gedrückt
      'z.B. "Call SubFuerA"
    Case "B"
      'Taste 'B' oder 'b' wurde gedrückt
      'z.B. "Call SubFuerB"
  End Select
End Sub

[45] Spaltennummern von mehreren selektierten Zellbereichen ausgeben

Zusammenfassung
Vielleicht haben Sie schon mal die Information benötigt, welche Spalten die aktuelle Selektion umfasst. Wenn mehrere nichtangrenzende Zellbereiche markiert sind, ist die Abfrage der Spaltennummern nicht mehr ganz so einfach. Man könnte die Areas-Auflistung verwenden, um an die einzelnen Zellbereiche zu heranzukommen. Doch es gibt eine bedeutend einfachere Lösung, und zwar mit Intersect.

VBA-Code
Public Sub ShowColumnsOfSelectedRanges()
  Dim intCount As Integer
  Dim intCol As Integer
  Dim strCols As String
  For intCol = 1 To Columns.Count
    If Not Intersect(Selection, Columns(intCol)) Is Nothing Then
      strCols = strCols & intCol & ", "
      intCount = intCount + 1
    End If
  Next intCol
  MsgBox "Die Selektion umfasst diese " & intCount & " Spalten:" & vbCrLf & vbCrLf & Left(strCols, Len(strCols) - 2)
End Sub

Prozedur testen
Selektieren Sie beliebige Zellbereiche auf einem Tabellenblatt und rufen Sie dann die Prozedur auf. Sie können testhalber auch diese Anweisung im Direktfenster ausführen, mit der ein paar Bereiche markiert werden.

Range("F5:H8,K2:K15,J11:J13,N5:P5,M18:N18").Select

[46] Formelzellen neu berechnen

Zusammenfassung
Falls die Formelzellen auf einem Tabellenblatt trotz eingestelltem automatischen Berechnungsmodus nicht neu berechnet werden, kann man mit diesem kleinen Makro die Neuberechnung explizit anstossen. Anhand der Replace-Methode werden alle Zellen, die ein Gleich-Zeichen enthalten, durch schlichtes Ersetzen des Gleich-Zeichens durch wiederum ein Gleich-Zeichen, neu berechnet.

VBA-Code
Public Sub RecalcFormulas()
  Cells.Replace What:="=", Replacement:="=", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
End Sub

Haben Sie Fragen, Anregungen oder einen Fehler entdeckt?
Mail senden an: philipp_von_wartburg@yahoo.de

Zuletzt aktualisiert am 08.01.2009 / 08:00 Uhr
© 2002-2009 by Philipp von Wartburg, Schweiz
Alle Rechte vorbehalten