probleem met excel code

[Renevatio]

Hallo,

Ik heb volgende code op het net gevonden. Nu had ik graag dat tijdens het uitvoeren van deze code "EMPLOYEE" in de listbox niet meer te voorschijn komt. Ik heb het bereik van de listbox aangepast waardoor employee verdwijnt en nu een blanco cel is. Weet er iemand hoe je de namen die er onder staan gewoon één rij naar boven kan schuiven zodat mijn listbox start met "Abraham lincoln".

Bedankt



'When a name in the listbox is double-clicked, select the corresponding row
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim Employee As Variant
Dim Name As String
Dim firstaddress As String
If IsNull(ListBox1.Value) Then Exit Sub
Employee = Empty
'If you add more than 500 names you will need to increase this
With ActiveSheet.Range("a1:a500")
Name = ListBox1.Value
Set Employee = .Find(what:=Name, LookIn:=xlValues)
If Not Employee Is Nothing Then Employee.Rows.EntireRow.Select Else Exit Sub
End With
'closes the form when you double-click on a name
Unload Me
Set Employee = Nothing
End Sub

Private Sub UserForm_activate()

Dim MyList(9, 3) 'as array type
Dim R As Integer

'The list box contains 1 data column.
'You can configure the number of columns, their width and height below
'as well as change the text in the ControlTipText of the listbox
Application.ShowToolTips = True
With ListBox1
.ColumnCount = 1
.ColumnWidths = 75
.Width = 230
.Height = 110
.ControlTipText = "Click the Name, Job, or ID you're after"
End With

'Define the list and where it's obtained from (Columns A, D, G in this example)
With ActiveSheet

'MyList (Row{0 to 9}, Column{0 to 2}) = the ranges given
For R = 0 To 9
MyList(R, 0) = .Range("A" & R + 1)
MyList(R, 1) = .Range("D" & R + 1)
MyList(R, 2) = .Range("G" & R + 1)
Next R
End With[/COLOR]
'populate the list box
ListBox1.List = MyList

End Sub

'This sub uses the list box to select the name on the spreadsheet
'and display their picture if one is found
Private Sub listBox1_Click()

Dim EmpFound As Range
Dim fPath As String

'selects the range to look for a name. You have to have a range
'named myName set up on column A. Go to insert-name-define to
'see how this one is set up.
With Range("myName")
Set EmpFound = .Find(ListBox1.Value)
On Error Resume Next
If EmpFound Is Nothing Then
Image1.Picture = LoadPicture(fPath & "nopic.gif")
Else
With EmpFound
'Look in the directory where this workbook is located.
fPath = ThisWorkbook.Path & "\"
On Error Resume Next
'If a matching picture is found then display it.
Image1.Picture = LoadPicture(fPath & "\" & ListBox1.Value & ".jpg")
'If No picture found then display the default picture.
If Err = 0 Then Exit Sub
Image1.Picture = LoadPicture(fPath & "nopic.gif")
End With
End If
End With
Set EmpFound = Nothing
End Sub

 

[Relleboer]

Zip het bestand er ff bij dat maakt het makkelijker voor de gene wie een oplossing heeft

 

[Wigi]

Zip het bestand er ff bij dat maakt het makkelijker voor de gene wie een oplossing heeft

En evt. ook een link naar de pagina waar je dit gevonden hebt. Is meer netjes tgo. de schrijver van de code.

 

[Renevatio]

Hier is het bestand.
Sorry maar ik weet niet meer juist waar ik het gedowl heb

 

[Withaar]

In Private Sub UserForm_activate() staat o.a. dit;

      'Define the list and where it's obtained from (Columns A, D, G in this example)
      With ActiveSheet

            'MyList (Row{0 to 9}, Column{0 to 2}) = the ranges given
            For R = 0 To 9
                  MyList(R, 0) = .Range("A" & R + 1)
                  MyList(R, 1) = .Range("D" & R + 1)
                  MyList(R, 2) = .Range("G" & R + 1)
            Next R
      End With

MyList(R, 0) = .Range("A" & R + 1) zorgt er voor dat de getoonde rij begind met cel A1.
Maak er MyList(R, 0) = .Range("A" & R + 2) van en het wordt A2... (R=0 +2 is A2)

N.b. Getoonde lijstje is nu maar 9 namen lang, ook als je er 500 hebt ingevoerd.
Verander de For R = 0 To 9 in For R = 0 To 500 om bv 500 namen te laten zien in de lijst.
Ook moet je in dat geval het array aanpassen; Dim MyList(9, 3) 'as array type wordt Dim MyList(500, 3) 'as array type

 

[Renevatio]

Hey hartelijk dank withaar.

Weet je toevallig ook hoe je er voor kan zorgen dat als je dubbel klikt op de naam niet de rij geselecteerd wordt maar de naam gewoon in een lege cel wordt ingevoegd.

 

[Withaar]

'When a name in the listbox is double-clicked, copy text to cel.
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim Employee As Variant
Dim Name As String
Dim firstaddress As String
If IsNull(ListBox1.Value) Then Exit Sub
Employee = Empty
'If you add more than 500 names you will need to increase this

'With ActiveSheet.Range("a1:a500")
' Name = ListBox1.Value
' Set Employee = .Find(what:=Name, LookIn:=xlValues)
' If Not Employee Is Nothing Then Employee.Rows.EntireRow.Select Else Exit Sub
'End With
Name = ListBox1.Value
Sheets("Sheet2").Range("C3") = Name

'closes the form when you double-click on a name
Unload Me
Set Employee = Nothing
End Sub

Rood is de oude code, mag je verwijderen, maar kan ook blijven staan, groen de nieuwe, ik neem aan dat de werking zo wel duidelijk is.

 

[Renevatio]

Het is duidelijk Withaar er werkt perfect.

Ik ben nu bezig meerdere knoppen aan te maken die naar de listbox verwijzen. Het enige probleem is dat tijdens de activatie van de verschillende knoppen de tekst telkens in een ander veld dient ingegeven te worden.

Ik kan natuurlijk de code meerdere malen copieren en meerdere macros toevoegen maar is er geen elegantere manier die jij als expert kent.

 

[Renevatio]

Withaar,

Weet je hoe ik de tabel op sheet 2 kan plaatsen en dan in de array laten zoeken op sheet2?


Bedankt

 

[Withaar]

Private Sub UserForm_activate()
      Dim MyList(500)
      Dim R As Integer
      Application.ShowToolTips = True
      With ListBox1
            .ColumnCount = 1
            .ColumnWidths = 75
            .Width = 230
            .Height = 110
            .ControlTipText = "Click the Name, you're after"
      End With
           For R = 0 To 500
                  MyList(R) = Sheets("Sheet2").Range("A" & R + 2)
           Next R
     'populate the list box
      ListBox1.List = MyList
End Sub

Code direct maar een beetje opgeruimd.

T.a.v. je andere vraag;
Elke listbox heeft een eigen nummer de eerste die je gebruikte was;
Name = ListBox1.Value
Sheets("Sheet1").Range("C3") = Name

Voor een 2e wordt het dus;
Name = ListBox2.Value
Sheets("Sheet1").Range("vul zelf een cel in") = Name
gebruiken, elke listbox zal echter wel een eigen Private Sub ListBox(x) krijgen, daar ontkom je niet aan.

 

[Renevatio]

Oke bedankt withaar het ziet er al veel beter uit.
Ik heb nog een laatste vraagje. Als ik de kolom A van mijn voorbeeld verhuis naar blad twee en de aanpassingen doe die je zegt geven de namen in de listbox alleen maar de "no pic" gif meer.

De twee fotos van abraham en bart simpson zijn dus blijkbaar niet meer gelinkt.
Dien ik ook wijzigingen aan te brengen in dat stukje code?

 

[Withaar]

Aangepaste code:

Private Sub listBox1_Click()
      Dim fPath As String
        On Error Resume Next
                fPath = ThisWorkbook.Path & "\"
                On Error Resume Next
                'If a matching picture is found then display it.
                Image1.Picture = LoadPicture(fPath & "\" & ListBox1.Value & ".jpg")
                'If No picture found then display the default picture.
                If Err = 0 Then Exit Sub
                Image1.Picture = LoadPicture(fPath & "nopic.gif")
End Sub

Heel wat minder dus.
Als totaal ook in de bijlage.


Ps. zie niet dat 'On Error Resume Next' er nog 2x in staat, één er van mag ook nog vervallen...