Beispiel für Zielwertsuche | Herbers Excel Beispiele

ClassModule: Tabelle1

Private Sub Worksheet_Activate()
   Dim oBtn As CommandBarButton
   With Application.CommandBars("Cell")
      Set oBtn = .FindControl(ID:=21)
      oBtn.Enabled = False
   End With
End Sub

Private Sub Worksheet_Deactivate()
   Application.CommandBars("Cell").Reset
End Sub

StandardModule: Modul1

Sub ReadID()
   Dim sMsg As String
   sMsg = "Erstes Element im Zell-Kontextmenü:" & vbLf
   With Application.CommandBars("Cell").Controls(1)
      sMsg = sMsg & "Caption: " & .Caption & vbLf
      sMsg = sMsg & "ID: " & .ID
      MsgBox sMsg
   End With
End Sub

Sub ShowPosition()
   Dim iLeft As Integer, iTop As Integer
   iLeft = Application.InputBox("Linke Position:", , 200, Type:=1)
   iTop = Application.InputBox("Obere Position:", , 200, Type:=1)
   Application.CommandBars("Cell").ShowPopup iLeft, iTop
End Sub

Sub MonthMessage()
   MsgBox "Aufruf kam von " & _
      Application.CommandBars("Months") _
      .Controls(Application.Caller(1)).Caption
End Sub

Sub SetFilter()
   Dim iRow As Integer
   Application.ScreenUpdating = False
   Rows.Hidden = False
   iRow = 1
   Do Until IsEmpty(Cells(iRow, 1))
      If Weekday(Cells(iRow, 1).Value) <> Application.Caller(1) - 2 Then
         Rows(iRow).Hidden = True
      End If
      iRow = iRow + 1
   Loop
   Application.ScreenUpdating = True
End Sub

Sub ResetFilter()
   Rows.Hidden = False
End Sub

Sub SpaltenAus()
   Selection.EntireColumn.Hidden = True
End Sub

Sub SpaltenEin()
   Selection.EntireColumn.Hidden = False
End Sub

Sub InsertValue()
   ActiveCell.Value = Application.CommandBars("RowValues") _
      .Controls(Application.Caller(1)).Caption
End Sub

Sub SelectSheet()
   Worksheets(Application.CommandBars("SheetSelect") _
      .Controls(Application.Caller(1)).Caption).Select
End Sub

Sub DialogShortCutMenus()
   frmKontext.Show
End Sub

Sub ListShortCutMenus()
   Dim oBar As CommandBar
   Dim oCntr As CommandBarControl
   Dim iRow As Integer
   Application.ScreenUpdating = False
   Workbooks.Add
   Range("A1").Value = "Name"
   Range("B1").Value = "Lokaler Name"
   Range("C1").Value = "Eingebaut"
   Range("D1").Value = "Schaltflächen"
   Range("E1").Value = "ID"
   Rows(1).Font.Bold = True
   iRow = 1
   For Each oBar In Application.CommandBars
      If oBar.Type = msoBarTypePopup Then
         iRow = iRow + 1
         Cells(iRow, 1) = oBar.Name
         Cells(iRow, 2) = oBar.NameLocal
         Cells(iRow, 3) = oBar.BuiltIn
         For Each oCntr In oBar.Controls
            Cells(iRow, 4) = oCntr.Caption
            Cells(iRow, 5) = oCntr.ID
            iRow = iRow + 1
         Next oCntr
      End If
   Next oBar
   Columns.AutoFit
   Application.ScreenUpdating = False
End Sub
ClassModule: frmKontext

Private Sub cboControl_Change()
   If cboControl.Text = "" Then Exit Sub
   lblIndexControl.Caption = _
      Application.CommandBars(cboKontext.Text) _
      .Controls(cboControl.Text).ID
End Sub

Private Sub cboKontext_Change()
   Dim objBar As CommandBar
   Dim objCntr As CommandBarControl
   Set objBar = Application.CommandBars(cboKontext.Text)
   lblIndexMenu.Caption = objBar.Index
   lblNameLocal.Caption = objBar.NameLocal
   cboControl.Clear
   For Each objCntr In objBar.Controls
      cboControl.AddItem objCntr.Caption
   Next objCntr
   cboControl.ListIndex = 0
End Sub

Private Sub cmdCancel_Click()
   Unload Me
End Sub

Private Sub cmdOK_Click()
   Unload Me
   Call ListShortCutMenus
End Sub

Private Sub UserForm_Initialize()
   Dim objBar As CommandBar
   For Each objBar In CommandBars
      If objBar.Type = msoBarTypePopup Then
         cboKontext.AddItem objBar.Name
      End If
   Next objBar
   cboKontext.ListIndex = 0
End Sub
ClassModule: Tabelle3

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   If Not Intersect( _
      Target, Range("A1:F16")) Is Nothing Then
      Cancel = True
   End If
End Sub

ClassModule: Tabelle4

Private Sub Worksheet_Activate()
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim iCounter As Integer
   On Error Resume Next
   Application.CommandBars("Months").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "Months", msoBarPopup, False, True)
   For iCounter = 1 To 12
      Set oBtn = oBar.Controls.Add
      With oBtn
         .Caption = Format( _
            DateSerial(1, iCounter, 1), "mmmm")
         .Style = msoButtonCaption
         .OnAction = "MonthMessage"
      End With
   Next iCounter
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("Months").Delete
   On Error GoTo 0
End Sub

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Application.CommandBars("Months").ShowPopup
End Sub

ClassModule: Tabelle5

Private Sub Worksheet_Activate()
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim iCounter As Integer
   On Error Resume Next
   Application.CommandBars("Days").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "Days", msoBarPopup, False, True)
   Set oBtn = oBar.Controls.Add
   With oBtn
      .Caption = "Wochentage:"
      .Style = msoButtonCaption
   End With
   For iCounter = 1 To 7
      Set oBtn = oBar.Controls.Add
      With oBtn
         .Caption = Cells(5 + iCounter, 1).Text
         .Style = msoButtonCaption
         .OnAction = "SetFilter"
         If iCounter = 1 Then
            .BeginGroup = True
         End If
      End With
   Next iCounter
   Set oBtn = oBar.Controls.Add
   With oBtn
      .Caption = "Zurücksetzen"
      .Style = msoButtonCaption
      .OnAction = "ResetFilter"
      .BeginGroup = True
   End With
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("Days").Delete
   On Error GoTo 0
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Application.CommandBars("Days").ShowPopup
End Sub

ClassModule: Tabelle6

Private Sub Worksheet_Activate()
   Dim oBar As CommandBar
   Dim oPopUp As CommandBarPopup
   Dim oCntr As CommandBarControl
   Dim oBtn As CommandBarButton
   On Error Resume Next
   Application.CommandBars("KonNames").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "KonNames", msoBarPopup, False, True)
   Set oPopUp = Application.CommandBars.FindControl(ID:=30023)
   For Each oCntr In oPopUp.Controls
      Set oBtn = oBar.Controls.Add(ID:=oCntr.ID)
   Next oCntr
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("KonNames").Delete
   On Error GoTo 0
End Sub

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   Application.CommandBars("KonNames").ShowPopup
End Sub
ClassModule: Tabelle7

Private Sub Worksheet_Activate()
   Dim oBtn As CommandBarButton
   With Application.CommandBars("Cell")
      On Error Resume Next
      .Controls("Spalten aus").Delete
      .Controls("Spalten ein").Delete
      On Error GoTo 0
      Set oBtn = .Controls.Add
      oBtn.Caption = "Spalten aus"
      oBtn.Style = msoButtonCaption
      oBtn.OnAction = "SpaltenAus"
      oBtn.BeginGroup = True
      Set oBtn = .Controls.Add
      oBtn.Caption = "Spalten ein"
      oBtn.Style = msoButtonCaption
      oBtn.OnAction = "SpaltenEin"
   End With
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   With Application.CommandBars("Cell")
      .Controls("Spalten aus").Delete
      .Controls("Spalten ein").Delete
   End With
   On Error GoTo 0
End Sub

ClassModule: Tabelle8

Private Sub Worksheet_Activate()
   Dim oPopUp As CommandBarControl
   Dim oBtn As CommandBarButton
   On Error Resume Next
   Application.CommandBars("Cell") _
      .Controls("Spalten").Delete
   On Error GoTo 0
   Set oPopUp = Application.CommandBars( _
      "Cell").Controls.Add(msoControlPopup)
   With oPopUp
      .Caption = "Spalten"
      .BeginGroup = True
   End With
   Set oBtn = oPopUp.Controls.Add
   With oBtn
      .Caption = "Spalten aus"
      .Style = msoButtonCaption
      .OnAction = "SpaltenAus"
   End With
   Set oBtn = oPopUp.Controls.Add
   With oBtn
      .Caption = "Spalten ein"
      .Style = msoButtonCaption
      .OnAction = "SpaltenEin"
   End With
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("Cell") _
      .Controls("Spalten").Delete
   On Error GoTo 0
End Sub

ClassModule: Tabelle9

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim iCol As Integer
   If WorksheetFunction.CountA( _
      Range(Cells(Target.Row, 3), _
      Cells(Target.Row, 256))) = 0 Then Exit Sub
   Cancel = True
   On Error Resume Next
   Application.CommandBars("RowValues").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "RowValues", msoBarPopup)
   For iCol = 3 To 256
      If Not IsEmpty(Cells(Target.Row, iCol)) Then
         Set oBtn = oBar.Controls.Add
         With oBtn
            .Caption = Cells(Target.Row, iCol).Value
            .Style = msoButtonCaption
            .OnAction = "InsertValue"
         End With
      End If
   Next iCol
   Application.CommandBars("RowValues").ShowPopup
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("RowValues").Delete
   On Error GoTo 0
End Sub
ClassModule: Tabelle10

Private Sub Worksheet_BeforeRightClick( _
   ByVal Target As Range, Cancel As Boolean)
   Dim oBar As CommandBar
   Dim oBtn As CommandBarButton
   Dim wks As Worksheet
   Cancel = True
   On Error Resume Next
   Application.CommandBars("SheetSelect").Delete
   On Error GoTo 0
   Set oBar = Application.CommandBars.Add( _
      "SheetSelect", msoBarPopup)
   For Each wks In Worksheets
      If wks.Index <> Me.Index Then
         Set oBtn = oBar.Controls.Add
         With oBtn
            .Caption = wks.Name
            .Style = msoButtonCaption
            .OnAction = "SelectSheet"
         End With
      End If
   Next wks
   Application.CommandBars("SheetSelect").ShowPopup
End Sub

Private Sub Worksheet_Deactivate()
   On Error Resume Next
   Application.CommandBars("SheetSelect").Delete
   On Error GoTo 0
End Sub

Zielwertsuche auf mehrere Zeilen anwenden	Zielwertsuche, aber anders
Zielwertsuche	Zielwertsuche oder Solver oder?
Zielwertsuche	Zielwertsuche
Zielwertsuche	Mehrfachoperation bei integrierten Zielwertsuche
Installation: Microsoft Excel-Feature	Zielwertsuche
mehr Nachkommastellen bei Zielwertsuche	Zielwertsuche
Zielwertsuche	Zielwertsuche
Zielwertsuche	Zielwertsuche über VBA ....
Zielwertsuche	Zielwertsuche?
bedingte Zielwertsuche mit Makro	Zielwertsuche liefert nicht zulässigen Wert
Zielwertsuche	Zielwertsuche fest auf einer Zelle verankern
Wertebereich der Zielwertsuche beschränken?	Zielwertsuche
Zielwertsuche mit Excel4Macros	Zielwertsuche
Finanzmathe Beispiel mit Zielwertsuche :)	Zielwertsuche Bsp.
Extremwerte mit Zielwertsuche	Limit für Zielwertsuche nach oben und unten
Makro für Zielwertsuche	Features werden bei jedem Aufruf neu installiert
manuelle Zielwertsuche vermeiden	Zielwertsuche aus Zelle
Zielwertsuche	Zielwertsuche
Zielwertsuche	SVerweis u. Zielwertsuche
SVerweis u. Zielwertsuche	Makro Zielwertsuche
Zielwertsuche-Unregelmäßigkeiten	Zielwertsuche über Eingabaufforderung
Makro - Zielwertsuche	Wenn dann Funktion, Zielwertsuche,,.....
zielwertsuche problem	Zielwertsuche
Zielwertsuche automatisieren	Zielwertsuche
Zielwertsuche	vb code für funktion zielwertsuche

Thema: Beispiel für Zielwertsuche

Beiträge aus dem Excel-Forum zu den Themen Feature und Zielwertsuche