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
