Ole object of Active X Combobox.

Status
Niet open voor verdere reacties.
Ok, blijkbaar heb jij bijna het hele traject van "voortschrijdend inzicht" doorlopen.
Soms heb je hier op het forum vragen onder het motto "waarom makkelijk doen als het moeilijk kan" maar dat is hier dus niet aan de orde.
Nu terug naar de oplossing.

Ik had dat ook met active-x buttons (om kolommen weg te halen en terug te zetten),
die werden alsmaar groter.
Ben overgestapt op een cell-event en dat werkt gewoon voortreffelijk. Je klikt op de
cell, de kolommen verdwijnen, de tekst wordt in de cell aangepast en vice versa.

Dus met "eenvoud" en geen onnodige ballast op het werkblad is het beste imo, ook
omdat niemand iets kan wijzigen. Dat wil zeggen, een startmacro schrijft gewoon
altijd alles opnieuw. en de macro's zijn minimaal.

Ik gebruik 1 routine voor 8 comboboxen en op zich werkt dat allemaal maar
alleen de match op één of twee karakters gaat niet goed.

Wellicht moet ik mijn projectje even kuisen (gegevens-gevoelig en hier plaatsen.
 
Ik heb wellicht enige onnodige code gemaakt maar het gaat om het idee.

Eerst het volledige script en als bijlage de gekuiste sheet.
Code:
Sub Worksheet_SelectionChange(ByVal Target As Range)

'oude combobox(en)  verwijderen
For y = 1 To intake.Shapes.Count: intake.Shapes(y).Delete: Next

If Target.Column = 3 Then 'hierbij wordt alleen kolom 3 afgevangen

Select Case Target.Row 'voorlopig alleen de genoemde cellen worden afgevangen
    Case 3, 7, 8, 9, 10, 11

'Zoeken naar de juiste kolom in blad gegevens, de naastliggende cel in kolom D wordt hiervoor gebruikt
a = ActiveCell.Offset(0, 1) 'de oomschrijving waarop gezocht

For x = 1 To 20
If a = gegevens.Cells(1, x) Then Exit For
Next

'laatste gevulde cel zoeken in gevonden kolom
y = gegevens.Cells(gegevens.Rows.Count, x).End(xlUp).Row
kol = Chr(x + 64) 'hiermee wordt kolomnummer omgezet in kolomletter (nodig voor Listfillrange)

Set ctlcombo = intake.OLEObjects.Add(ClassType:="Forms.combobox.1", Link:=False)
With ctlcombo
        .Name = "cbo"
        .Left = Target.Left
        .Top = Target.Top
        .Width = Target.Width
        .Height = Target.Height
        .ListFillRange = ""
        .ListFillRange = "gegevens" & "!" & kol & 2 & ":" & kol & y
        .Object.MatchEntry = 2
        .Object.MatchRequired = False
        .Object.ListRows = 20
End With
End Select
End If
End Sub


Public Sub cbo_change()
ActiveCell = cbo.Text
If cbo.Text > "" Then ActiveCell.Interior.Color = 14811105
ActiveCell.Offset(1, 1).Select
End Sub
Bekijk bijlage intakehelpforum - geschoond.xlsm

Ik heb nog even een en ander opgeschoond.
 

Bijlagen

  • intakehelpforum.xlsm
    109,3 KB · Weergaven: 35
Laatst bewerkt:
Afijn, na een (intensieve) maand ben al een stuk verder maar heb nog
wat probleempjes. Nu wordt een OleObejct-Combox gegenereerd na het
klikken op een aantal (geselecteerde cellen (grijs gekleurd)).
De Combobox wordt gevuld met de referentie in de naastgelegen cel en
haalt zijn gegevens op uit het blad Data (so far so good).

Op het klikken klapt de combobox uit en er verschijnt een overzicht welke
je kunt kiezen met een muisklik, ook dat werkt. Na de klik wordt de
onderliggende cel gevuld, de combobox verdwijnt en... op naar de volgende.

ECHTER;
Als je kiest voor eigen input dan 1. ontstaat er enerzijds geen overzicht met
de mogelijkheden en 2. (erger nog) de combobox verdwijnt.

Wie kan mij verder helpen. Als bijlage de betreffende sheet.

en hier even wat code;
Code:
Option Explicit
Public rij As Integer
Public kol As Integer
Public rng As Range
Public cbox1 As Object
Public ComboBox1 As Combobox
Public keycode As Integer
Public y As Integer

Sub vensters() 'Deze macro wordt aangeroepen uit blad "intake"
Dim zoekterm As String
Set rng = intake.Cells(rij, kol)

'bestaande comboboxen weghalen
For y = 1 To intake.Shapes.Count: intake.Shapes(y).Delete: Next

If kol = 3 Then 'hierbij wordt alleen kolom 3 afgevangen
    Select Case rij 'voorlopig alleen de genoemde cellen worden afgevangen
        Case 3, 7, 8, 9, 10, 11
zoekterm = intake.Cells(rij, kol).Offset(0, 1)

Dim x As Integer ' hier wordt bepaalt in welke kolom te zoeken in blad "gegevens"
For x = 1 To 20
    If zoekterm = gegevens.Cells(1, x) Then Exit For
Next

Dim aantal As Integer 'aantal te zoeken in blad "gegevens"
aantal = gegevens.Cells(gegevens.Rows.Count, x).End(xlUp).Row

'Hier wordt de combobox in betreffende cel geplaatst.
Set cbox1 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", _
    Link:=False, _
    DisplayAsIcon:=False, _
    Left:=rng.Left, _
    Top:=rng.Top, _
    Width:=rng.Width, _
    Height:=rng.Height).Object

'Hier wordt de combobox gevuld.
For y = 2 To aantal
    cbox1.AddItem gegevens.Cells(y, x)
Next

'En dan is het tobben
cbox1.AutoWordSelect = True
cbox1.Style = fmStyleDropDownCombo
cbox1.MatchEntry = fmMatchEntryFirstLetter
cbox1.MatchRequired = True

End Select
End If
End Sub
 

Bijlagen

  • Intakenieuw10072017.xlsm
    30 KB · Weergaven: 21
Kijk eens hier, daar is het ook niet opgelost.
Er zal wel een reden zijn waarom we dit soort controls niet vaker zien.
 
Laatst bewerkt:
Ben een stuk verder en wil dat graag delen.

De code in de module is;
Code:
Option Explicit
Public rij As Integer
Public kol As Integer
Public rng As Range
Public cbox1 As Object
Public ComboBox1 As Combobox
Public KeyCode As Integer
Public y As Integer

Sub vensters() 'Deze macro wordt aangeroepen uit blad "intake"
Dim zoekterm As String
Dim arr() As Variant
Set rng = intake.Cells(rij, kol)

If kol = 3 Then 'hierbij wordt alleen kolom 3 afgevangen
    Select Case rij 'voorlopig alleen de genoemde cellen worden afgevangen
        Case 3, 7, 8, 9, 10, 11
zoekterm = intake.Cells(rij, kol).Offset(0, 1)

Dim X As Integer ' hier wordt bepaalt in welke kolom te zoeken in blad "gegevens"
For X = 1 To 20
If zoekterm = gegevens.Cells(1, X) Then Exit For
Next

Dim aantal As Integer 'aantal te zoeken in blad "gegevens"
aantal = gegevens.Cells(gegevens.Rows.Count, X).End(xlUp).Row

arr = gegevens.Range(gegevens.Cells(2, X), gegevens.Cells(aantal, X))

'Hier wordt de combobox in betreffende cel geplaatst.
Set cbox1 = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", _
    Link:=False, _
    DisplayAsIcon:=False, _
    Left:=rng.Left, _
    Top:=rng.Top, _
    Width:=rng.Width, _
    Height:=rng.Height).Object
ActiveSheet.OLEObjects("combobox1").Activate 'zorgt voor de focus

'ComboBox1.AutoWordSelect = False
cbox1.List = arr 'Hier wordt de combobox gevuld.

'En dan is het nog steeds een beetje tobben
cbox1.DropDown 'doet het nu ook, rows klappen uit.
cbox1.Locked = False
cbox1.AutoWordSelect = True
cbox1.Style = 0 '0=fmStyleDropDownCombo 2=list
cbox1.MatchEntry = 1 '1=fmMatchEntryComplete
cbox1.MatchRequired = False
cbox1.ShowDropButtonWhen = 2

End Select
End If
End Sub

Sub zet_events_uit()
Application.EnableEvents = False
End Sub

Sub zet_events_aan()
Application.EnableEvents = True
End Sub


De code in het blad (waarden afvangen);
Code:
Option Explicit

Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim y As Integer: y = Shapes.Count
If y > 0 Then
For y = 1 To Shapes.Count: Shapes(y).Delete
Next
End If
rij = Target.Row: kol = Target.Column
vensters 'macro in moduleblad
End Sub

Private Sub combobox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
    zet_events_uit 'macro in moduleblad
    ActiveCell = ComboBox1.Value
    zet_events_aan 'macro in moduleblad
    ActiveCell.Offset(0, 1).Select 'ga een cel naar beneden om zo de macro te stoppen.
End If
End Sub

Public Sub combobox1_change()
Exit Sub
End Sub


Public Sub combobox1_click()
Exit Sub
End Sub

Maar het kraakt nog een beetje. Het juist afvangen van de ingevoegde
waarden is tobben. Soms met een enter bevestigen en soms met een muisklik.
Niet lekker consequent. Wie het weet mag 't zeggen.
 

Bijlagen

  • Intakenieuw13072017.xlsm
    31 KB · Weergaven: 24
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan