Update gekoppelde tabellen werkt traag

[Wasaki]

Graag langs deze hulp gevraagd voor volgende probleem.

 

Ik heb 2 Excel bestanden die normaal op een verschillende locatie staan (voorlopig op desktop)

Een file als databestand, de andere als werkbestand, beide versleuteld let paswoord 'Test'

Bedoeling is om vanuit het werkbestand, via een formulier, data weg te schrijven naar het databestand.

Het werkbestand is 1 op 1 gekoppeld met het databestand, zodat toevoegingen ook daar verschijnen.

Probleem nu is dat het, bij aanklikken van de knop 'Bewaren' in het formulier, tot 16 seconden duurt tot de data weggeschreven is.

Hieronder de code:

 

Private Sub CommandButton1_Click()
On Error Resume Next
ActiveSheet.Unprotect ("Test")

If Dir("C:\Users\WHuylebro\Desktop\Test_Data.xlsm") <> "" Then
    Set xlapp = CreateObject("Excel.Application")
    xlapp.DisplayAlerts = False
    Set XLwb = xlapp.Workbooks.Open("C:\Users\WHuylebro\Desktop\Test_Data.xlsm")
    Set XLsh = xlapp.Worksheets("Lijst")
    XLsh.Unprotect ("Test")
    aantal = XLsh.Cells(1, 1).Value
    XLsh.Cells(4 + aantal, 1).Value = aantal + 1
    XLsh.Cells(4 + aantal, 2).Value = "CU"
    XLsh.Cells(4 + aantal, 3).Value = Now
    XLsh.Cells(4 + aantal, 4).Value = TextBox1.Text
    XLsh.Cells(4 + aantal, 5).Value = TextBox4.Text
    xlapp.Worksheets("Lijst").Protect Password:="Test", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
            UserInterfaceOnly:=True, AllowFormattingCells:=False, AllowFormattingColumns:=True, _
            AllowFormattingRows:=True, AllowInsertingColumns:=False, AllowInsertingRows:=False, _
            AllowInsertingHyperlinks:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, _
            AllowSorting:=False, AllowFiltering:=True, AllowUsingPivotTables:=False
    XLwb.Save
    XLwb.Close
    ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
Else
    MsgBox ("Datafile niet bereikbaar!" & vbCrLf & "Gelieve uw aanvraag via een andere pc door te sturen")
End If

ComboBox1.Text = ""
ComboBox2.Text = ""
TextBox1.Text = ""
TextBox2.Text = ""
TextBox4.Text = ""
ActiveSheet.Protect Password:="Test", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
        UserInterfaceOnly:=True, AllowFormattingCells:=False, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=False, AllowInsertingRows:=False, _
        AllowInsertingHyperlinks:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, _
        AllowSorting:=False, AllowFiltering:=True, AllowUsingPivotTables:=False
ActiveSheet.ShowAllData
ActiveSheet.Cells(ActiveSheet.Cells(1, 1) + 3, 1).Select

Me.Hide

End Sub
 

Thx,

Wasaki