Meerdere regels matchen en in een custom msgbox plaatsen.

[Nicknero1405]

Hallo allemaal.

Ik ben voor mijn werk bezig met het maken van een VBA macro die een excel bestand opent en daarin naar een naam gaat zoeken in kolom D, vervolgens de artikelnummer uit kolom B in de zelfde regel te halen en terug te sturen als string.

Alleen nu kom ik met de volgende stap, en daar snap ik nog niet zo veel van:
Nu wil ik er voor zorgen dat als je de naam die je zoekt twee of meerdere keren vind in kolom D, dat hij dan van iedere rij die hij gevonden heeft de descriptie uit kolom A haalt (iedere rij heeft dus een andere descriptie) en dat gebruikt in een custom msgbox zodat je kan selecteren welke van de gevonden rijen je wilt gebruiken.

Ik hoop dat ik hiermee duidelijk ben, anders probeer ik het wel stap voor stap uit te leggen wat er moet gebeuren:
- als hij maar 1 regel vind, moet hij doen wat hij nu al doet.
- als hij meer regels vind. moet hij OF:
-- iedere gevonden regel de informatie uit kolom B halen en in een aparte string stoppen. Bijvoorbeeld
gevonden regel 1 = strmatch1
gevonden regel 2 = strmatch2
-- of hij moet een custom msgbox openen met een lijst met alle gevonden regels, informatie uit kolom B, en uit kolom A om te
weten welke daarvan je nodig hebt. en dan kun je selecteren welke je wilt gebruiken.

Voorbeeld van de custom msgbox layout:

"De database bevat bevat meerdere gevonden regels. Selecteer de juiste descriptie, en druk volgens op OK"
o <info kolom B> - <info kolom A>
o <info kolom B> - <info kolom A>
o <info kolom B> - <info kolom A>
OK


Het script wat ik gemaakt heb waar dit dus bij hoort:

Sub main()
Dim oExcel As Excel.Application
Dim oWB As Workbook
Dim oWS As Excel.Worksheet
Dim strartno, strmodel As String
Dim retval As Boolean
Dim strRow
Dim part
Dim noMatch As String
Dim frmCustom
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swConfigMgr As SldWorks.ConfigurationManager
Dim swConfig As SldWorks.Configuration


Set oExcel = New Excel.Application
Set swApp = CreateObject("SldWorks.Application")
Set part = swApp.ActiveDoc
strFilename = part.GetTitle



oExcel.Visible = False

Set oWB = oExcel.Workbooks.Open("file:///\\savas-sbs1\Openbaar\400 Ont\00 Bibliotheek\Tekeningen\TEKART.xls")

On Error GoTo Einde:

With oWB.Sheets("Sheet1")
    strRow = WorksheetFunction.Match((strFilename), .Range("D1:D15000"), 0) 'Hier zoekt hij het bestandsnaam in kolom D
    strartno = .Range("B" & strRow).Value                                   'Hier haalt hij de info uit kolom B en zet het in een string
End With
Excel.Application.DisplayAlerts = False
Excel.Application.Quit
oExcel.Quit

On Error GoTo 0
    sConfig = ("Default")
    strCP2 = "Art. nr"
    strCP = "Art. nr."
    strartno3 = part.CustomInfo2(sConfig, strCP2)
        If strartno3 <> "" Then
            retval = part.DeleteCustomInfo2(sConfig, strCP2)
        End If
    strartno2 = part.CustomInfo2(sConfig, strCP)
        If strartno2 = "" Then
                retval = part.DeleteCustomInfo2(sConfig, strCP)
                retval = part.AddCustomInfo3(sConfig, strCP, swCustomInfoText, strartno)
            MsgBox ("Van " & strFilename & " is artikelcode " & strartno & " gevonden en toegevoegd als custom property: " & strCP)
        
        ElseIf strartno2 <> strartno Then
            strexist = MsgBox("Artikelnummer van " & strFilename & " bestaat al. Wil je " & strartno2 & " vervangen voor " & strartno & "?", 36)
                If strexist = 6 Then
                    retval = part.DeleteCustomInfo2(sConfig, strCP)
                    retval = part.AddCustomInfo3(sConfig, strCP, swCustomInfoText, strartno)
                    MsgBox ("Artikel nummer van " & strFilename & " is van " & strartno2 & " vervangen voor " & strartno & " en toegevoegd als custom property: " & strCP)
                End If
        End If

Einde:
'error afhandeling
Select Case Err.Number
    Case 0
    
    Case 1004
        noMatch = MsgBox(strFilename & " is niet gevonden in de database.")
        Excel.Application.Quit
        oExcel.Quit

    Case Else
        MsgBox "Er is een fout opgetreden" & vbCr & _
               Err.Description & "(" & Err.Number & ")"
        Excel.Application.Quit
        oExcel.Quit
        
End Select
'Objects to void
Set oExcel = Nothing
Set oWB = Nothing
Set part = Nothing
Set strFilename = Nothing
Set strartno = Nothing
Set strRow = Nothing

End Sub

 

[Mark xl]

kijk eens naar onderstaande code (vervang je with owb.sheets("Sheet1") ... end With) met dit

en kijk eens of je er wat mee kunt


Update: Tweede codeblok is een verkorte versie van 1

With oWB.Sheets("Sheet1")

    Dim rSearch As Range
    Dim rFound As Range
    Dim strmsg As String
    Dim r As Long
    
    Set rSearch = .Columns("D").Find(strfilename, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
    Set rFound = rSearch
    
    If Not rSearch Is Nothing Then
    
        strmsg = "rij " & rSearch.row & ", " & rSearch.Offset(, -2) & vbCr
        r = rSearch.row
    
    End If
    
    Do While Not rSearch Is Nothing
    
        Set rSearch = .Columns("D").Find(strfilename, After:=rSearch, LookIn:=xlValues, _
                                    lookat:=xlPart, MatchCase:=False)
        If r >= rSearch.row Then Exit Do
        strmsg = strmsg & "rij = " & rSearch.row & ", Artikelcode = " & rSearch.Offset(, -2) & vbCr
        Set rFound = Union(rFound, rSearch)
    
    Loop

    Dim cell As Range
    
    For Each cell In rFound
    
        If MsgBox("bedoelde u " & cell.Offset(, -2) & " - " & strfilename & "?", vbYesNo) = vbYes Then
            
            strartno = cell.Offset(, -2)
            Exit For
            
        End If
    
    Next

    If strartno = "" Then Exit Sub
    
    

    Set rSearch = Nothing
    
    If strmsg <> "" Then MsgBox strmsg, vbInformation

End With

en onnodige code verwijderd...

With oWB.Sheets("Sheet1")

    Dim rSearch As Range
    Dim r As Long
    
    Set rSearch = .Columns("D").Find(strfilename, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
    
    If Not rSearch Is Nothing Then
        
        r = rSearch.row
        
        Do
            If MsgBox("bedoelde u " & rSearch.Offset(, -2) & " - " & strfilename & "?", vbYesNo) = vbYes Then
                
                strartno = cell.Offset(, -2).Value
                Set rSearch = Nothing
                Exit Do
            
            End If
            
            Set rSearch = .Columns("D").Find(strfilename, After:=rSearch, LookIn:=xlValues, _
                              lookat:=xlPart, MatchCase:=False)
            If r >= rSearch.row Then Exit Do
        
        Loop
    
    End If

    If strartno = "" Then Exit Sub

End With

 

[Nicknero1405]

Hmmm ziet er goed uit, alleen heeft de 1e code een 1004 error als hij meerdere dingen gevonden heeft.

De tweede werkt echter wel met meerdere, alleen krijg je daarbij een error: Object required(424) zodra je op JA klikt.

Ook kan dit misschien wel werken, alleen zou ik het liever hebben dat hij zoals in mijn OP uitgelegd is iedere regel in een string zet zodat ik die kan gebruiken in een userform (custom messagebox)

Is dit mogelijk?

 

[Mark xl]

Natuurlijk

je kunt ipv de messagebox ook bijvoorbeeld

'<start loop>

Userform1.combobox1.additem rSearch.Offset(, -2)

'<einde loop>

Userform1.show

Probeer daar eens wat mee.

 

[Nicknero1405]

Aaw ik had gehoopt dat ik die userForm zelf wel uit zou vogelen, maar ik kom er niet uit.
Ik heb nog nooit een userForm gemaakt, dus ik weet ook niet precies hoe het gaat, maar ik denk in ieder geval dat je alle opties een group naam moet geven. zodat je weet welke bij elkaar horen.
Maar hoe zorg ik er nu voor dat de naam van 1 zo'n optie word zoals je aangeeft in het script (bijvoorbeeld dus als naam: rSearch.Offset(, -2) & " - " & strdescr )

Owja en van jou regel snap ik denk ik wel, maar ik wil het even zeker weten:
Userform1 is de naam van de userform.
combobox1 is de group naam van je opties.
Klopt dit?

en:
additem weet ik niet wat en waar hij precies iets toevoegt.
wat doet dit precies?


Alvast zeer bedankt voor de tweede keer dat je mij zo goed helpt.

 

[Mark xl]

Als je een userform hebt toegevoegd, Kun je hierop controls toevoegen

gebruik hiervoor de "werkset"
als deze niet zichtbaar is, selecteer je userform en ga in het menu naar (Beeld > Werkset)
(ik weet dat je engelse office hebt, maar ik ken de engelse termen niet 100%)

ga nu met je muis over de verschillende elementen heen om te kijken hoe ze heten

Plaats een "Opdrachtknop"(commandbutton) en een "Keuzelijst met invoervak"(combobox) in je userform

als je nu op de knop dubbelklikt krijg je het volgende te zien:

Private sub commandbutton1_click

End sub

voer daartussen je code in die je wilt laten uitvoeren als je op de knop drukt
bijvoorbeeld:

Private sub commandbutton1_click
    Msgbox "ok"
    Me.hide
End sub

Selecteer nu je userform en druk op F5, waarna je op de knop ok klikt, zoals je ziet wordt de code uitgevoerd.

Selecteer nu je "keuzelijst met invoervak"(combobox)
als het goed is zie je linksonderin beeld het venster eigenschappen (zo niet: F4)

zoek in het eigenschappen venster naar de eigenschap "MatchEntry", en zet deze op "1-MatchEntryComplete" kijk goed dat je de combobox geselecteerd hebt

Vervang nu de code die ik eerder gepost heb door:

With oWB.Sheets("Sheet1")

    Dim rSearch As Range
    Dim r As Long
    
    Set rSearch = .Columns("D").Find(strfilename, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
    
    If Not rSearch Is Nothing Then
        
        r = rSearch.row
        
        Do
                
            userform1.combobox1.AddItem cell.Offset(, -2).Value & " - " & strfilename
            userform1.combobox1.Value = cell.Offset(, -2).Value & " - " & strfilename
            
            Set rSearch = .Columns("D").Find(strfilename, After:=rSearch, LookIn:=xlValues, _
                              lookat:=xlPart, MatchCase:=False)
            If r >= rSearch.row Then Exit Do
        
        Loop
    
        userform1.Show
        strartno = Mid(combobox1.Value, 1, InStr(combobox1.Value, " - ") - 1)
        Unload userform1
    
    End If

    If strartno = "" Then Exit Sub

End With

combobox.additem voegt een item toe aan de lijst
combobox.value stelt een waarde in voor de combobox = een soort select

 

[Nicknero1405]

Het basis van het maken van een userform snap ik wel, daar heb ik namelijk een mooie voorbeeld voor gevonden: http://gregmaxey.mvps.org/Custom_MsgBox.htm

Alleen hier gebruikt hij alleen maar commandbuttons, dus bedankt voor jou voorbeeld met een selectie menu.

Alleen als ik hem probeer te testen krijg ik net als bij jou vorige tweede voorbeeld een error: Object required(424)

regel

UserForm1.ComboBox1.AddItem cell.Offset(, -2).Value & " - " & strfilename

Enig idee wat hier fout van is dan?

 

[Mark xl]

Excuses! ik heb per ongeluk en verkeerde referentie gebruikt.
het moet zijn rSearch en niet Cell

ik kan niet zo goed de code testen, vandaar.

With oWB.Sheets("Sheet1")

    Dim rSearch As Range
    Dim r As Long
    
    Set rSearch = .Columns("D").Find(strfilename, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
    
    If Not rSearch Is Nothing Then
        
        r = rSearch.row
        
        Do
                
            userform1.combobox1.AddItem rSearch.Offset(, -2).Value & " - " & strfilename
            userform1.combobox1.Value = rSearch.Offset(, -2).Value & " - " & strfilename
            
            Set rSearch = .Columns("D").Find(strfilename, After:=rSearch, LookIn:=xlValues, _
                              lookat:=xlPart, MatchCase:=False)
            If r >= rSearch.row Then Exit Do
        
        Loop
    
        userform1.Show
        strartno = Mid(combobox1.Value, 1, InStr(combobox1.Value, " - ") - 1)
        Unload userform1
    
    End If

    If strartno = "" Then Exit Sub

End With

 

[Nicknero1405]

Geweldig! Zeer bedankt.
Nu hoef ik alleen nog maar de userform goed in te stellen, en toe te voegen dat als hij maar 1 match gevonden heeft hij de userform overslaat.

Daar kom ik (hopelijk) zelf wel uit, dus daar heb ik (nog) geen hulp bij nodig

<thread gemarkeerd als opgelost>
Thanks.

Edit:

Ik kreeg nog een aantal foutmeldingen, maar ik heb ze zelf al gefixed met puur gokken.
Zo had je bijvoorbeeld deze regel:

strartno = Mid(ComboBox1.Value, 1, InStr(ComboBox1.Value, " - ") - 1)

Daarbij kreeg je nog een Object not set error.
Maar dat heb ik simpel weg zo aangepast:

strartno = Mid(UserForm1.ComboBox1.Value, 1, InStr(UserForm1.ComboBox1.Value, " - ") - 1)

 

[Nicknero1405]

Goed, nu ik dacht dat ik bijna klaar was, loopt ik alweer tegen een fout aan waar ik echt geen raad meer van weet, dus ik hoop dat iemand anders dat wel heeft:

Code:

Sub main()
Dim oExcel As Excel.Application
Dim oWB As Workbook
Dim oWS As Excel.Worksheet
Dim strartno, strmodel As String
Dim retval As Boolean
Dim strRow
Dim part
Dim noMatch As String
Dim frmCustom
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swConfigMgr As SldWorks.ConfigurationManager
Dim swConfig As SldWorks.Configuration
Dim myForm As UserForm1
Set myForm = New UserForm1


Set oExcel = New Excel.Application
Set swApp = CreateObject("SldWorks.Application")
Set part = swApp.ActiveDoc
strfilename = part.GetTitle



oExcel.Visible = False

Set oWB = oExcel.Workbooks.Open("file:///\\savas-sbs1\Openbaar\400 Ont\00 Bibliotheek\Tekeningen\TEKART.xls")

On Error GoTo Einde:

With oWB.Sheets("Sheet1")

    Dim rSearch As Range
    Dim r As Long
    
    Set rSearch = .Columns("D").Find(strfilename, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
    
    If Not rSearch Is Nothing Then
[B]        strtimesfound = 0[/B]
        r = rSearch.Row
        UserForm1.Partnaam.Value = rSearch.Value
            Do
[B]                strtimesfound = strtimesfound + 1[/B]
                UserForm1.ComboBox1.AddItem rSearch.Offset(, -2).Value & " - (" & rSearch.Offset(, -3).Value & ")"
                UserForm1.ComboBox1.Value = rSearch.Offset(, -2).Value & " - (" & rSearch.Offset(, -3).Value & ")"
            
                Set rSearch = .Columns("D").Find(strfilename, After:=rSearch, LookIn:=xlValues, _
                              lookat:=xlPart, MatchCase:=False)
                If r >= rSearch.Row Then Exit Do
        
            Loop

[B]        If strtimesfound > 1 Then[/B]
            UserForm1.Show
            Select Case UserForm1.Tag
                Case 0
                    strartno = ""
                    Unload UserForm1
                    GoTo Einde:
                Case 1
                    strartno = Mid(UserForm1.ComboBox1.Value, 1, InStr(UserForm1.ComboBox1.Value, " - ") - 1)
                    Unload UserForm1
            End Select
[B]        Else
        strartno = rSearch.Offset(, -2)
        End If[/B]
    End If

End With

MsgBox strartno

On Error GoTo 0
    sConfig = ("Default")
    strCP2 = "Art. nr"
    strCP = "Art. nr."
    strartno3 = part.CustomInfo2(sConfig, strCP2)
        If strartno3 <> "" Then
            retval = part.DeleteCustomInfo(strCP2)
        End If
    strartno2 = part.CustomInfo2(sConfig, strCP)
        If strartno2 = "" Then
                retval = part.DeleteCustomInfo(strCP)
                retval = part.AddCustomInfo3(sConfig, strCP, swCustomInfoText, strartno)
            MsgBox ("Van " & strfilename & " is artikelcode " & strartno & " gevonden en toegevoegd als custom property: " & strCP)
        
        ElseIf strartno2 <> strartno Then
            strexist = MsgBox("Artikelnummer van " & strfilename & " bestaat al. Wil je " & strartno2 & " vervangen voor " & strartno & "?", 36)
                If strexist = 6 Then
                    retval = part.DeleteCustomInfo(strCP)
                    retval = part.AddCustomInfo3(sConfig, strCP, swCustomInfoText, strartno)
                    MsgBox ("Artikel nummer van " & strfilename & " is van " & strartno2 & " vervangen voor " & strartno & " en toegevoegd als custom property: " & strCP)
                End If
        End If

Einde:
'error afhandeling
Select Case Err.Number
    Case 0
    
    Case 1004
        noMatch = MsgBox(strfilename & " is niet gevonden in de database.")
        Excel.Application.Quit
        oExcel.Quit

    Case Else
        MsgBox "Er is een fout opgetreden" & vbCr & _
               Err.Description & "(" & Err.Number & ")"
        Excel.Application.DisplayAlerts = False
        Excel.Application.Quit
        
End Select
oExcel.Quit
'Objects to void
Set oExcel = Nothing
Set oWB = Nothing
Set part = Nothing
Set strfilename = Nothing
Set strartno = Nothing
Set strRow = Nothing

End Sub

Problemen:

1. Alles werkt fantastisch als ik een nieuwe naam als custom propertie aangeef, maar als ik die naam verander naar een bestaande custom propertie uit een template, dan ziet het er wel naar uit dat alles werkt, maar ookal zecht de messagebox van wel, toch verandert hij de custom propertie NIET naar wat ik hem opgeef.

2. Als de find functie maar 1 match vind, moet hij de custom message box overslaan en gewoon die ene waarde die hij gevonden heeft gebruiken. Hoe krijg ik dit voor elkaar?

Edit:
Probleem 2 heb ik net zelf al opgelost. Ik was gewoon heel moeilijk aan het nadenken, terwijl het zeer gemakkelijk op te lossen was (dik gedrukt is toegevoegd aan de code)