Übertrag EXCEL in ACCESS
11.01.2019 16:00:13
Alexander
Hallo wir haben uns einen Code geschrieben der besagt dass er eine Liste aus einer Tabelle in Access schreibt, meine Frage gibt es eine Möglichkeit das ganze noch etwas zu optimieren was die Übertragungsgeschwindigkeit angeht ?
Sub DatenInAccessDB()
Range("B22") = Now
Makro4
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
SearchEmploymentDate
Dim MsgText As String
On Error GoTo Err_Handler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim SQL As String
sDataBaseFile = Worksheets("Setting").Cells(2, 3).Value
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set db = OpenDatabase(sDataBaseFile)
While Worksheets("DB_Transfer").Cells(3, 1).Value ""
SQL = "Select * From " & Worksheets("Setting").Cells(2, 4).Value & " Where ID Is Null;"
Set db = OpenDatabase(sDataBaseFile)
Set rs = db.OpenRecordset(SQL)
With rs
.AddNew
For i = 1 To Worksheets("Setting").Cells(2, 5).Value
.Fields(Worksheets("DB_Transfer").Cells(2, i).Value) = Worksheets("DB_Transfer") _
.Cells(3, i).Value
Next
.Fields("Frei20") = Worksheets("DB_Transfer").Cells(3, 25).Value
.Update
End With
Worksheets("DB_Transfer").Rows("3:3").Delete Shift:=xlUp
Worksheets("PERSONALPLANUNG").Cells(22, 2).Interior.Color = RGB(0, 255, 128)
rs.Close
db.Close
Wend
End_Handler:
Set rs = Nothing
Set db = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Call Calculate
Exit Sub
Err_Handler:
Worksheets("DB_Transfer").Cells(1, 1).Interior.Color = RGB(204, 0, 0)
msgNetzwerkfehler
Resume End_Handler
End Sub