Hilfreiche Funktionen und Prozeduren

    • VBA: Excel

      Hilfreiche Funktionen und Prozeduren

      Ich möchte hier ein paar Funktionen und Prozeduren vorstellen, die mir beim Programmieren in Excel hilfreich sind:


      Folgende Prozedur bewirkt, dass alle Zellen im Bereich quadratisch sind. Ist HöheBeibehalten False, wird die Breite beibehalten.

      Visual Basic-Quellcode

      1. Sub QuadratischeZellen(Bereich As Range, Optional HöheBeibehalten As Boolean = True)
      3. Dim Zelle As Range
      5. For Each Zelle In Bereich
      6. If HöheBeibehalten Then
      7. While Zelle.Width <> Zelle.Height
      8. Zelle.ColumnWidth = Zelle.ColumnWidth / Zelle.Width * Zelle.Height
      9. Wend
      10. Else
      11. While Zelle.Width <> Zelle.Height
      12. Zelle.RowHeight = Zelle.RowHeight / Zelle.Height * Zelle.Width
      13. Wend
      14. End If
      15. Next
      17. End Sub


      Folgende Funktion liefert die Mappe, die unter Dateipfad gespeichert ist. Ist die Mappe bereits offen, wird die geöffnete Mappe zurückgegeben.

      Visual Basic-Quellcode

      1. Function DateiMappe(Dateipfad As String) As Workbook
      3. Dim i As Integer
      5. For i = 1 To Workbooks.Count
      6. If Workbooks(i).FullName = Dateipfad Then
      7. Set DateiMappe = Workbooks(i)
      8. Exit Function
      9. End If
      10. Next
      11. Set DateiMappe = Workbooks.Open(Dateipfad)
      13. End Function


      Folgende Prozedur schließt die Mappe, die unter Dateipfad gespeichert ist, sofern sie geöffnet ist.

      Visual Basic-Quellcode

      1. Sub DateiSchließen(Dateipfad As String, Optional ÄnderungenSpeichern As Boolean = False)
      3. Dim i As Integer
      5. For i = 1 To Workbooks.Count
      6. If Workbooks(i).FullName = Dateipfad Then
      7. Workbooks(i).Close SaveChanges:=ÄnderungenSpeichern
      8. Exit Sub
      9. End If
      10. Next
      12. End Sub


      Folgende Prozedur speichert die Mappe unter Dateipfad, wobei eine evtl. bestehende Datei überschrieben wird. Sollte so eine Mappe bereits geöffnet sein, wird sie vorher mit DateiSchließen (s. o.) geschlossen. Bei Excel 2007 speichere ich meistens als „.xlsm“-Datei also als XML-Mappe mit Makros. Für ältere Excel-Versionen empfiehlt sich statt xlOpenXMLWorkbookMacroEnabled xlNormal.

      Visual Basic-Quellcode

      1. Sub DateiNeuSpeichern(Mappe As Workbook, Dateipfad As String, Optional Dateiformat As XlFileFormat = xlOpenXMLWorkbookMacroEnabled)
      3. DateiSchließen Dateipfad
      4. Application.DisplayAlerts = False
      5. Mappe.SaveAs Dateipfad, Dateiformat
      6. Application.DisplayAlerts = True
      8. End Sub


      Folgende Funktion erstellt eine neue Mappe und speichert sie mit obiger Prozedur DateiNeuSpeichern. Diese neue Mappe ist der Rückgabewert der Funktion.

      Visual Basic-Quellcode

      1. Function NeueDateiSpeichern(Dateipfad As String, Optional Dateiformat As XlFileFormat = xlOpenXMLWorkbookMacroEnabled) As Workbook
      3. Set NeueDateiSpeichern = Workbooks.Add()
      4. DateiNeuSpeichern NeueDateiSpeichern, Dateipfad, Dateiformat
      6. End Function


      Folgende Funktion liefert einen String, der die Werte im Bereich enthält.

      Visual Basic-Quellcode

      1. Function RangeString(Bereich As Range, Zeilentrennung As String, Spaltentrennung As String, Optional Rahmen As Boolean = True) As String
      3. Dim z As Long, s As Integer
      5. With Bereich
      6. For z = 1 To .Rows.Count
      7. If z > 1 Then RangeString = RangeString & Zeilentrennung
      8. For s = 1 To .Columns.Count
      9. If s > 1 Then RangeString = RangeString & Spaltentrennung
      10. RangeString = RangeString & .Cells(z, s)
      11. Next
      12. Next
      13. End With
      14. If Rahmen Then RangeString = Zeilentrennung & RangeString & Zeilentrennung
      16. End Function


      Bei folgender Funktion wird in der UsedRange der Tabelle in der Suchspalte der Suchtext gesucht. Wird er gefunden, werden die Werte der entsprechenden Zeile als Array zurückgegeben. Wenn nicht, wird ein Array zurückgegeben, das nur das Element 0 enthält, welches leer ist.

      Visual Basic-Quellcode

      1. Function SuchArray(Tabelle As Worksheet, Suchtext As String, Optional Suchspalte As Integer = 1) As Variant()
      3. Dim Erg() As Variant, Bereich As Range, Zeile As Long, i As Integer
      5. ReDim Erg(0)
      6. Set Bereich = Tabelle.UsedRange
      7. If WorksheetFunction.CountIf(Bereich.Columns(Suchspalte), Suchtext) > 0 Then
      8. Zeile = WorksheetFunction.Match(Suchtext, Bereich.Columns(Suchspalte), 0)
      9. ReDim Erg(Bereich.Columns.Count)
      10. For i = 1 To Bereich.Columns.Count
      11. Erg(i) = Bereich.Cells(Zeile, i)
      12. Next
      13. End If
      14. SuchArray = Erg
      16. End Function


      Folgende Funktion fügt der Tabelle die Werte hinzu. Die Schlüsselspalte gibt dabei die Spalte mit dem Primärschlüssel an, also die Spalte, in der ein Wert nur einmal vorkommen darf. Gibt es keine solche Spalte, muss man 0 angeben.

      Visual Basic-Quellcode

      1. Function WerteHinzufügen(Tabelle As Worksheet, Schlüsselspalte As Integer, ParamArray Werte() As Variant) As Long
      3. Dim hinzufügen As Boolean, Zeile As Long, i As Integer
      5. If Schlüsselspalte = 0 Then
      6. hinzufügen = True
      7. Else
      8. hinzufügen = (WorksheetFunction.CountIf(Tabelle.Columns(Schlüsselspalte), Werte(Schlüsselspalte - 1)) = 0)
      9. End If
      10. If hinzufügen Then
      11. Zeile = Tabelle.UsedRange.Rows.Count + 1
      12. If Zeile = 2 Then If Tabelle.UsedRange.Cells.Count = 1 Then Zeile = 1
      13. For i = 0 To UBound(Werte)
      14. Tabelle.Cells(Zeile, i + 1) = Werte(i)
      15. Next
      16. WerteHinzufügen = Zeile
      17. End If
      19. End Function


      Folgende Prozedur sortiert die UsedRange der Tabelle nach den Spalten. Ob auf- oder absteigend sortiert werden soll, wird durch das Vorzeichen der Spalte bestimmt.

      Beispiel:

      Visual Basic-Quellcode

      1. UsedRangeSort Sheets("Tabelle1"), False, 3, 1, -5, 4
      sortiert die UsedRange von Tabelle1, die keine Überschriften hat, erst nach Spalte 3 aufsteigend, dann nach Spalte 1 aufsteigend, dann nach Spalte 5 absteigend und dann nach Spalte 4 aufsteigend.

      Zu erwähnen wäre noch, dass ich es so eingestellt habe, dass Zahlen, die als Text formatiert sind, als Text behandelt werden (DataOption:=xlSortNormal) und dass Groß-/Kleinschreibung nicht beachtet wird (MatchCase:=False).

      Version für Excel 2007:

      Visual Basic-Quellcode

      1. Sub UsedRangeSort(Tabelle As Worksheet, Überschriften As Boolean, ParamArray Spalten() As Variant)
      3. Dim i As Integer, Bereich As Range
      5. Set Bereich = Tabelle.UsedRange
      6. With Tabelle.Sort
      7. .SortFields.Clear
      8. For i = 0 To UBound(Spalten)
      9. .SortFields.Add Key:=Bereich.Columns(Abs(Spalten(i))), SortOn:=xlSortOnValues, Order:=1.5 - Sgn(Spalten(i)) / 2, DataOption:=xlSortNormal
      10. Next
      11. .SetRange Bereich
      12. .Header = IIf(Überschriften, xlYes, xlNo)
      13. .MatchCase = False
      14. .Orientation = xlTopToBottom
      15. .SortMethod = xlPinYin
      16. .Apply
      17. End With
      19. End Sub


      Version für ältere Excel-Versionen:

      Visual Basic-Quellcode

      1. Sub UsedRangeSortAlt(Tabelle As Worksheet, Überschriften As Boolean, ParamArray Spalten() As Variant)
      3. Dim i As Integer, StartNr As Integer, Bereich As Range
      5. Set Bereich = Tabelle.UsedRange
      6. Select Case UBound(Spalten)
      7. Case 0
      8. Bereich.Sort _
      9. Key1:=Bereich.Cells(1 - Überschriften, Spalten(0)), Order1:=1.5 - Sgn(Spalten(0)) / 2, DataOption1:=xlSortNormal, _
      10. Header:=IIf(Überschriften, xlYes, xlNo), OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
      11. Case 1
      12. Bereich.Sort _
      13. Key1:=Bereich.Cells(1 - Überschriften, Spalten(0)), Order1:=1.5 - Sgn(Spalten(0)) / 2, DataOption1:=xlSortNormal, _
      14. Key2:=Bereich.Cells(1 - Überschriften, Spalten(1)), Order2:=1.5 - Sgn(Spalten(1)) / 2, DataOption2:=xlSortNormal, _
      15. Header:=IIf(Überschriften, xlYes, xlNo), OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
      16. Case 2
      17. Bereich.Sort _
      18. Key1:=Bereich.Cells(1 - Überschriften, Spalten(0)), Order1:=1.5 - Sgn(Spalten(0)) / 2, DataOption1:=xlSortNormal, _
      19. Key2:=Bereich.Cells(1 - Überschriften, Spalten(1)), Order2:=1.5 - Sgn(Spalten(1)) / 2, DataOption2:=xlSortNormal, _
      20. Key3:=Bereich.Cells(1 - Überschriften, Spalten(2)), Order3:=1.5 - Sgn(Spalten(2)) / 2, DataOption3:=xlSortNormal, _
      21. Header:=IIf(Überschriften, xlYes, xlNo), OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
      22. Case Else
      23. StartNr = (UBound(Spalten) \ 3) * 3
      24. Select Case UBound(Spalten) Mod 3
      25. Case 0: UsedRangeSortAlt Tabelle, Überschriften, Spalten(StartNr)
      26. Case 1: UsedRangeSortAlt Tabelle, Überschriften, Spalten(StartNr), Spalten(StartNr + 1)
      27. Case 2: UsedRangeSortAlt Tabelle, Überschriften, Spalten(StartNr), Spalten(StartNr + 1), Spalten(StartNr + 2)
      28. End Select
      29. For i = 0 To StartNr - 3 Step 3
      30. UsedRangeSortAlt Tabelle, Überschriften, Spalten(i), Spalten(i + 1), Spalten(i + 2)
      31. Next
      32. End Select
      34. End Sub