Warnhinweis bei Leerzeilen
14.06.2019 15:07:45
Xilence
Danke für die Hilfe
Sub DatenInAccessDB()
Call Differenzen_T_minus_S_in_Y_
Dim MsgText As String
On Error GoTo Err_Handler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim SQL As String
Dim wksZ As Worksheet, ZeiZ As Long, SpaZ As Long
Set wksZ = Worksheets("Archiv") 'Name ggf. anpassen
With wksZ
ZeiZ = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
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 rs = db.OpenRecordset(SQL)
With rs
.AddNew
ZeiZ = ZeiZ + 1
SpaZ = 1
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
wksZ.Cells(ZeiZ, SpaZ).Value = Worksheets("DB_Transfer").Cells(3, i).Value
SpaZ = SpaZ + 1
Next
.Fields("ErrorProof2") = Worksheets("DB_Transfer").Cells(3, 25).Value
wksZ.Cells(ZeiZ, SpaZ).Value = Worksheets("DB_Transfer").Cells(3, 25).Value
.Update
End With
Worksheets("DB_Transfer").Rows("3:3").Delete Shift:=xlUp
Worksheets("DB_Transfer").Cells(1, 1).Interior.Color = RGB(0, 255, 128)
rs.Close
Wend
db.Close
End_Handler:
Set rs = Nothing
Set db = Nothing
Exit Sub
Err_Handler:
Worksheets("DB_Transfer").Cells(1, 1).Interior.Color = RGB(204, 0, 0)
msgNetzwerkfehler
Resume End_Handler
End Sub