HERBERS Excel-Forum - VBA-Basics

Thema: XL4-Makros in VBA verwenden

Inhaltsverzeichnis
  • 1 Zum Aufruf von XL4-Makros in VBA
  • 2 Programmierbeispiele
  • Zum Aufruf von XL4-Makros in VBA

    Es gibt Bereiche - beispielsweise das Setzen oder Auslesen der PageSetup-Eigenschaften -, in denen VBA deutliche Performance-Nachteile gegenüber alten XL4-Makros aufzeigt. Zudem bieten XL4-Makros Features, die von den VBA-Entwicklern nicht mehr berücksichtigt wurden. Dazu gehört unter anderem die Möglichkeit, Werte aus geschlossenen Arbeitsmappen auszulesen. Der Aufruf von XL4-Makros ist - wie in den nachfolgenden Prozeduren gezeigt wird - aus VBA heraus möglich. Man beachte die Laufzeitschnelligkeit im Vergleich zu VBA-Makros.

    Programmierbeispiele

    Auslesen eines Wertes aus geschlossener Arbeitsmappe

    
    Function xl4Value(strParam As String) As Variant
        xl4Value = ExecuteExcel4Macro(strParam)
    End Function
    
    Sub CallValue()
       Dim strSource As String
       strSource = _
          "'" & _
          Range("A2").Text & _
          "\[" & Range("B2").Text & _
          "]" & Range("C2").Text & _
          "'!" & Range("D2").Text
       MsgBox "Zellwert Zelle A1: " & xl4Value(strSource)
    End Sub
    
    

    Auslesen des ANZAHL2-Wertes aus geschlossener Arbeitsmappe

    
    Function xl4CountA(strParam As String) As Variant
        xl4CountA = _
          ExecuteExcel4Macro("CountA(" & strParam & ")")
    End Function
    
    Sub CallCountA()
       Dim strSource As String
       strSource = _
          "'" & _
          Range("A3").Text & _
          "\[" & Range("B3").Text & _
          "]" & Range("C3").Text & _
          "'!" & Range("D3").Text
       MsgBox "ANZAHL2 in A1:A100: " & xl4CountA(strSource)
    End Sub
    
    

    Auslesen einer Summe aus geschlossener Arbeitsmappe

    
    Function xl4Sum(strParam As String) As Variant
        xl4Sum = _
          ExecuteExcel4Macro("Sum(" & strParam & ")")
    End Function
    
    Sub CallSum()
       Dim strSource As String
       strSource = _
          "'" & _
          Range("A4").Text & _
          "\[" & Range("B4").Text & _
          "]" & Range("C4").Text & _
          "'!" & Range("D4").Text
       MsgBox "SUMME in A1:B100: " & xl4Sum(strSource)
    End Sub
    
    

    Auslesen eines SVERWEIS-Wertes aus geschlossener Arbeitsmappe

    
    Function xl4VLookup(strParam As String) As Variant
        xl4VLookup = ExecuteExcel4Macro _
          ("VLookup(""" & Range("E5").Text & _
          """, " & strParam & ", " & _
          Range("F5").Text & ", " & _
          Range("G5").Text & ")")
    End Function
    
    Sub CallVLookup()
       Dim strSource As String
       strSource = _
          "'" & _
          Range("A5").Text & _
          "\[" & Range("B5").Text & _
          "]" & Range("C5").Text & _
          "'!" & Range("D5").Text
       MsgBox "SVERWEIS in A1:B100: " & _
          xl4VLookup(strSource)
    End Sub
    
    

    Auslesen einer Tabelle aus geschlossener und Einlesen in neue Arbeitsmappe

    
    Sub ReadTable()
       Dim wks As Worksheet
       Dim intRow As Integer, intCol As Integer
       Dim strSource As String
       Application.ScreenUpdating = False
       Set wks = ActiveSheet
       Workbooks.Add
       For intRow = 1 To 20
          For intCol = 1 To 2
             strSource = _
                "'" & _
                wks.Range("A3").Text & _
                "\[" & wks.Range("B2").Text & _
                "]" & wks.Range("C2").Text & _
                "'!R" & intRow & "C" & intCol
             Cells(intRow, intCol).Value = _
                xl4Value(strSource)
          Next intCol
       Next intRow
       Application.ScreenUpdating = True
    End Sub
    
    

    SVERWEIS aus XL4 anwenden

    Bei Eingabe eines Suchbegriffes in Spalte A SVERWEIS-Wert in Spalte B eintragen Der Code muss sich im Klassenmodul der Tabelle befinden. Die Daten werden aus der geschlossenen Arbeitsmappe ohne Formeleinsatz ausgelesen.

    
    Private Sub Worksheet_Change(ByVal Target As Range)
       Dim strSource As String
       If Target.Column <> 1 Then Exit Sub
       With Worksheets("FalseLinks")
          strSource = _
             "'" & _
             .Range("A5").Text & _
             "\[" & .Range("B5").Text & _
             "]" & .Range("C5").Text & _
             "'!" & .Range("D5").Text
       End With
       Target.Offset(0, 1).Value = _
          xl4VLookupEvent(strSource, Target.Text)
    End Sub
    
    Private Function xl4VLookupEvent( _
       strParam As String, _
       strFind As String) As Variant
       With Worksheets("FalseLinks")
          xl4VLookupEvent = _
             ExecuteExcel4Macro("VLookup(""" & strFind & _
             """, " & strParam & ", " & _
             .Range("F5").Text & ", " & _
             .Range("G5").Text & ")")
       End With
    End Function
    
    

    Namen über XL4 erstellen und ausblenden

    Über XL4-Makros können Namen vergeben werden, die über die VBA-Eigenschaft Visible nicht angezeigt und den Befehl Delete nicht gelöscht werden können. Die Namen sind in allen Arbeitsmappen gültig und können als globale Variablen benutzt werden. Ihre Lebensdauer ist abhängig von der Excel-Sitzung. Routine zum Erstellen, Aufrufen und Löschen einer Text-Konstanten:

    
    Sub SetHiddenConst()
       Dim txt As String
       txt = InputBox("Bitte beliebige Meldung eingeben:", , _
          "Dies ist meine konstante Meldung!")
       If txt = "" Then Exit Sub
       Application.ExecuteExcel4Macro _
          "SET.NAME(""MyMsg"",""" & txt & """)"
    End Sub
    
    Sub GetHiddenConst()
       On Error Resume Next
       MsgBox Application.ExecuteExcel4Macro("MyMsg")
       If Err > 0 Then
          Beep
          Err.Clear
          MsgBox "Es wurde keine Konstante initialisiert!"
       End If
       On Error GoTo 0
    End Sub
    
    Sub DeleteHiddenConst()
       Application.ExecuteExcel4Macro "SET.NAME(""MyMsg"")"
    End Sub
    
    

    Benannte Formel über XL4 anlegen und aufrufen

    Routine zum Erstellen, Aufrufen und Löschen der Osterformel.

    
    Sub SetHiddenEastern()
       Application.ExecuteExcel4Macro _
          "SET.NAME(""OSTERN"",""=FLOOR(DATE(MyYear,3," & _
          "MOD(18.37*MOD(MyYear,19)-6,29)),7)+29"")"
    End Sub
    
    Sub GetHiddenEastern()
       On Error Resume Next
       MsgBox Format(Evaluate( _
          Application.ExecuteExcel4Macro("OSTERN")), _
          "dd.mm.yyyy")
       If Err > 0 Then
          Beep
          Err.Clear
          MsgBox "Es wurde kein Ostern initialisiert!"
       End If
       On Error GoTo 0
    End Sub
    
    Sub DeleteHiddenEastern()
       Application.ExecuteExcel4Macro "SET.NAME(""OSTERN"")"
    End Sub
    

    Routine zum Erstellen, Aufrufen und Löschen der Kalenderwochen-Formel

    
    Sub SetHiddenKW()
       Application.ExecuteExcel4Macro _
          "SET.NAME(""DINkw"",""=TRUNC((MyWK-WEEKDAY(MyWK,2)-" & _
          "DATE(YEAR(MyWK+4-WEEKDAY(MyWK,2)),1,-10))/7)"")"
    End Sub
    
    Sub GetHiddenKW()
       On Error Resume Next
       MsgBox Evaluate(Application.ExecuteExcel4Macro("DINkw"))
       If Err > 0 Then
          Beep
          Err.Clear
          MsgBox "Es wurde keine Kalenderwoche initialisiert!"
       End If
       On Error GoTo 0
    End Sub
    
    Sub DeleteHiddenKW()
       Application.ExecuteExcel4Macro "SET.NAME(""DINkw"")"
    End Sub
    

    Druckprobrammierung über XL4-Makros

    Wesentliche Geschwindigkeitsvorteile werden erreicht, wenn XL4-Makros beim Auslesen oder beim Setzen von PageSetup-Eigenschaften eingesetzt werden.

    Auslesen der Seitenzahl des aktiven Blattes

    
    Sub PageCountActiveSheet()
       MsgBox "Seitenanzahl: " & _
          ExecuteExcel4Macro("GET.DOCUMENT(50)")
    End Sub
    

    Auslesen der Seitenanzahl eines andere Blattes

    
    Sub PageCountOtherSheet()
       MsgBox "Seitenanzahl: " & _
          ExecuteExcel4Macro("Get.document(50,""DeleteRows"")")
    End Sub
    

    Auslesen der Seitenanzahl eines Blattes in einer anderen Arbeitsmappe

    
    Sub PageCountOtherWkb()
       Dim wkb As Workbook
       On Error Resume Next
       Set wkb = Workbooks("Test.xls")
       If Err > 0 Or wkb Is Nothing Then
          Beep
          MsgBox "Es muss eine Arbeitsmappe ""Test.xls"" geöffnet sein!"
          Exit Sub
       End If
       MsgBox "Seitenanzahl: " & _
          ExecuteExcel4Macro("Get.document(50,""[Test.xls]Tabelle1"")")
    End Sub
    

    Setzen von Druckeigenschaften wie Schriftgröße, Schriftart u.ä.

    
    Sub SetPageSetup()
       ExecuteExcel4Macro _
          "PAGE.SETUP("""",""&L&""""Arial,Bold""""&" & _
          "8MeineFirma GmbH & Co. KG&R&""""Arial,Bold""""&8&F," & _
          "&D,Seite 1"",0.75,0.75,0.91,0.5,FALSE,FALSE,TRUE,FALSE" & _
          ",2,1,95,#N/A,1,TRUE,,0.75,0.25,FALSE,FALSE)"
    End Sub
    
    

    Auslesen aller horizontalen und vertikalen Seitenumbrüche

    
    Sub GetPageBreaks()
       Dim horzpbArray() As Integer
       Dim verpbArray() As Integer
       Dim intCounter As Integer, intCol As Integer, intRow As Integer
       ThisWorkbook.Names.Add Name:="hzPB", _
          RefersToR1C1:="=GET.DOCUMENT(64,""PrintPages"")"
       ThisWorkbook.Names.Add Name:="vPB", _
          RefersToR1C1:="=GET.DOCUMENT(65,""PrintPages"")"
       intCounter = 1
       While Not IsError(Evaluate("Index(hzPB," & intCounter & ")"))
          ReDim Preserve horzpbArray(1 To intCounter)
          horzpbArray(intCounter) = Evaluate("Index(hzPB," & intCounter & ")")
          intCounter = intCounter + 1
       Wend
       ReDim Preserve horzpbArray(1 To intCounter - 1)
       intCounter = 1
       While Not IsError(Evaluate("Index(vPB," & intCounter & ")"))
          ReDim Preserve verpbArray(1 To intCounter)
          verpbArray(intCounter) = Evaluate("Index(vPB," & intCounter & ")")
          intCounter = intCounter + 1
       Wend
       ReDim Preserve verpbArray(1 To intCounter - 1)
       Workbooks.Add
       With Range("A1")
          .Value = "Horizontale Seitenumbrüche (Zeilen):"
          .Font.Bold = True
       End With
       For intRow = LBound(horzpbArray, 1) To UBound(horzpbArray, 1)
          Cells(intRow + 1, 1) = horzpbArray(intRow)
       Next intRow
       With Range("B1")
          .Value = "Vertikale Seitenumbrüche (Spalten):"
          .Font.Bold = True
       End With
       For intCol = LBound(verpbArray, 1) To UBound(verpbArray, 1)
          Cells(intCol + 1, 2) = verpbArray(intCol)
       Next intCol
       Columns.AutoFit
       Columns("A:B").HorizontalAlignment = xlCenter
    End Sub
    
    

    Schließen der Arbeitsmappe verhindern

    In den Excel-Versionen ab XL8 kann über das Workbook_BeforeClose-Ereignis das Schließen der Arbeitsmappe verhindert werden. Dieses Ereignis steht bei der Vorgängerversionen nicht zur Verfügung. Wenn also eine Arbeitsmappe abwärtskompatibel sein soll, kann hier ein XL4-Makro eingesetzt werden.

    
    Sub auto_close()
       If Worksheets("NoClose").CheckBoxes _
          ("chbClose").Value = xlOn Then
          ExecuteExcel4Macro "HALT(TRUE)"
          MsgBox "Das Schließen der Arbeitsmappe " & _
             "ist gesperrt -" & vbLf & _
             "Bitte zuerst die Sperre im " & _
             "Blatt ""NoClose"" aufheben!"
       End If
    End Sub
    
    

    Arbeitsblattmenüleiste zurücksetzen

    Über Schaltfläche kann die Arbeitsblattmenüleiste zurückgesetzt und die letzte Einstellung wieder gesetzt werden

    
    Sub MenuBar()
       With ActiveSheet.Buttons(1)
          If .Caption = "Menüleiste Reset" Then
             ExecuteExcel4Macro "SHOW.BAR(2)"
             .Caption = "Menüleiste zurück"
          Else
             ExecuteExcel4Macro "SHOW.BAR(1)"
             .Caption = "Menüleiste Reset"
          End If
       End With
    End Sub
    

    Bedingtes Löschen von Zeilen

    Das Löschen von Zeilen nach bestimmten Kriterien kann in VBA eine zeitwaufwendige Aufgabe sein, mit XL4-Makros ist das vergleichsweise schnell und einfach zu lösen

    
    Sub DeleteRows()
       Dim rngAll As Range, rngCriteria As Range
       Application.ScreenUpdating = False
       Set rngAll = Range("A1").CurrentRegion
       rngAll.Name = "'" & ActiveSheet.Name & "'!Datenbank"
       Set rngCriteria = rngAll.Resize(2, 1).Offset _
          (0, rngAll.Columns.Count + 1)
       With rngCriteria
          .Name = "'" & ActiveSheet.Name & _
             "'!Suchkriterien"
          .Cells(1, 1).Value = "Name"
          .Cells(2, 1).Formula = "'<>Hans W. Herber"
          ExecuteExcel4Macro "DATA.DELETE()"
          .Clear
       End With
       Application.ScreenUpdating = True
    End Sub