Thema: Neues Menü im Extras-Menü

ClassModule: DieseArbeitsmappe

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   Dim oPopUp As CommandBarPopup
   Set oPopUp = Application.CommandBars("Worksheet Menu Bar").FindControl(ID:=30007)
   On Error Resume Next
   oPopUp.Controls("Berechnungen").Delete
   On Error GoTo 0
End Sub

Private Sub Workbook_Open()
   Dim oPopUpA As CommandBarPopup
   Dim oPopUpB As CommandBarPopup
   Dim oButton As CommandBarButton
   Set oPopUpA = Application.CommandBars( _
      "Worksheet Menu Bar").FindControl(ID:=30007)
   On Error Resume Next
   oPopUpA.Controls("Berechnungen").Delete
   On Error GoTo 0
   Set oPopUpB = oPopUpA.Controls.Add(msoControlPopup)
   With oPopUpB
      .Caption = "Berechnungen"
      .BeginGroup = True
   End With
   Set oButton = oPopUpB.Controls.Add
   With oButton
      .Caption = "Daten anlegen"
      .OnAction = "AnlegenDaten"
   End With
   Set oButton = oPopUpB.Controls.Add
   With oButton
      .Caption = "Cbm errechnen"
      .OnAction = "ErrechnenCbm"
   End With
   Set oButton = oPopUpB.Controls.Add
   With oButton
      .Caption = "Qm Errechnen"
      .OnAction = "ErrechnenQm"
   End With
   oPopUpB.Visible = True
End Sub

StandardModule: basMain

Sub AnlegenDaten()
   Dim dFactor As Double
   Dim iRow As Integer, iCol As Integer
   dFactor = 1
   Range("A1") = "Länge"
   Range("B1") = "Breite"
   Range("C1") = "Höhe"
   Range("D1") = "Cbm"
   Range("E1") = "qmAfl"
   Rows(1).Font.Bold = True
   For iRow = 2 To 10
      For iCol = 1 To 3
         Cells(iRow, iCol) = 1.1 + dFactor
         dFactor = dFactor + dFactor * 0.1
      Next iCol
   Next iRow
   Columns("A:C").NumberFormat = "#,##0.00"
   Columns("D").NumberFormat = "#,##0.000"
   Columns("E").NumberFormat = "#,##0.00"
   Columns("A:E").HorizontalAlignment = xlRight
End Sub

Sub ErrechnenCbm()
   Dim iRow As Integer
   For iRow = 2 To 10
      Cells(iRow, 4).FormulaR1C1 = "=RC[-3]*RC[-2]*RC[-1]"
   Next iRow
End Sub

Sub ErrechnenQm()
   Dim iRow As Integer
   For iRow = 2 To 10
      Cells(iRow, 5).FormulaR1C1 = _
         "=2*(RC[-3]*RC[-2]+RC[-3]*RC[-1]+RC[-2]*RC[-1])"
   Next iRow
End Sub

Beiträge aus dem Excel-Forum zu den Themen Menue und PopUp