Gebruik van filedialog en toetsen of deze reeds is geopend

[mvanbe]

Goedenavond allen,

Ik heb een goed werkende code die ik graag iets verder wil uitbreiden. Ik kan wel de puzzelstukjes vinden maar krijg het nog niet in elkaar. Onderstaande code hangt aan een knop en kopieert een specifieke celinhoud naar een ander Excel bestand waar vervolgens een zoekactie mee wordt uitgevoerd. Probleem is dat deze niet dynamisch is. Als het bestandsnaam wordt gewijzigd zal deze niet meer functioneren. Wat ik voor ogen heb:

Bij eerste keer gebruik van de knop Filedialog openen om het Excel bestand te selecteren en deze te opslaan in een variabel
Bij overige keren dat de knop gebruikt wordt toetsen of het bestand reeds open is
Als deze open is; bestand activeren/maximaliseren
Als deze niet open is; Filedialog openen


Alvast bedankt voor de moeite

Sub Zoeken_database()

    Dim lRow As Long
    Dim lRsp As Long
    On Error Resume Next
    
    If Not Application.Intersect(ActiveCell, Range("A8:BX2500")) Is Nothing Then


    Dim zoekopdracht
    Set zoekopdracht = Range("BA" & (ActiveCell.Row))
 
    lRsp = MsgBox(zoekopdracht & "opzoeken in database?", _
            vbQuestion + vbYesNo)
   
    If lRsp <> vbYes Then Exit Sub
    
        
    ChDir "C:\Users\*******\Desktop"
    Workbooks.Open filename:="C:\Users\*****\Desktop\database.xlsm"

    
    Selection.Copy
    Windows("database.xlsm").Activate
    
    zoekopdracht.Copy
    Range("R4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
      
     Windows("database.xlsm").Activate
     Windows("database.xlsm").WindowState = xlMaximized
           
      
    End If


End Sub

 

[snb]

Vermijd 'Select' en 'Activate' in VBA.

 

[HSV]

Bv.

Dim s0 As String
s0 = [COLOR=#3E3E3E]"C:\Users\*****\Desktop\database.xlsm"[/COLOR]
  If Dir(s0, vbDirectory) <> "" Then
    GetObject(s0).Windows(1).Visible = True
   Else
    Application.FileDialog(3).Show
  End If

 

[mvanbe]

Ik ben inmiddels al weer wat verder met mijn code. Onderstaande code laat de gebruiker middels filedialog een database bestand selecteren. Er wordt getoetst of dit bestand reeds is geopenend en vervolgens wordt er een specifieke cel met tekst naar toe gekopieerd. In het database bestand wordt hiermee een zoekactie gestart. Dit werkt allemaal super.

Wat mij nog niet is gelukt is om het pad van het geselecteerde bestand op te slaan en deze vervolgens te gebruiken als variabel i.p.v. het bestandsnaam 'hard' ingevoerd ("database"). Probleem is nu dat wanneer iemand het het bestand "database.xlsm" wijzigt van naam, onderstaande code niet meer werkt.

Iemand een idee hoe dit is op te lossen?

Daarnaast merk ik na gebruik wat performance problemen in Excel. Heb zelf ook nog niet ontdekt waar dit aan kan liggen..

Sub Zoeken_database()


UserForm1.Hide


    Dim TestWorkbook As Workbook
    Dim fd As Office.FileDialog
    Dim strFile As String
    Dim wbRekenmodel   As Workbook
    Dim wbVeilingen As Workbook
    Dim myPath As String
    Dim folderPath As String
    Dim fileonly As String

    Set wbRekenmodel = ThisWorkbook
  
    Set TestWorkbook = Nothing
    On Error Resume Next
    Set TestWorkbook = Workbooks("database.xlsm")
    On Error GoTo 0
    
    'Database openen
    If TestWorkbook Is Nothing Then
      
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
 
    With fd
 
    .Filters.Clear
    .Filters.Add "Excel Files", "*.xlsm?", 1
    .Title = "Selecteer het database bestand"
    .AllowMultiSelect = False
 
    .InitialFileName = "C:\Users\desktop"
 
    If .Show = True Then
        
        strFile = .SelectedItems(1)
        Workbooks.Open strFile
 
    End If
    End With
        
    Else
    
        On Error Resume Next
        
         'Met hulpkolom naam van Fabrikant extraheren uit actieve rij en kopieren naar database
         Dim zoekopdracht
         Set zoekopdracht = Range("BA" & (ActiveCell.Row))
 
         lRsp = MsgBox(zoekopdracht & "opzoeken in Database?" + vbCr + vbCr + "Deze functie werkt alleen als het bestand onderstaande bestandsnaam heeft:" + vbCr + vbCr + "database", _
                 vbQuestion + vbYesNo)
        
         If lRsp <> vbYes Then Exit Sub
                
         Windows("database.xlsm").Activate
         
         Application.ScreenUpdating = False
         zoekopdracht.Copy
         Sheets("Zoek").Range("R4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        'Code om van venster te wisselen: Database terug naar Rekenmodel
        Application.ScreenUpdating = False
        ThisWorkbook.Sheets("Data").Range("B2") = ThisWorkbook.Name

        ThisWorkbook.Sheets("Data").Range("B2").Copy
        Workbooks("database.xlsm").Worksheets("Zoek").Range("R5").PasteSpecial Paste:=xlPasteValues

       Application.ScreenUpdating = True
       
       'Code om database te activeren en maximaliseren
        Windows("database.xlsm").Activate
        Workbooks("database.xlsm").Sheets("Zoek").Activate
        Application.WindowState = xlMaximized
             
    End If
    

      
End Sub