Importar Datos De Excel A Access

[Fegna]

Soy nuevo aquí y no se si se pueden adjuntar archivos, pero te incluyo un programa que está funcionando.

Fernando

BaseMDB.rsEstructura.Open
BaseMDB.rsUsuarios.Open
BaseMDB.rsDatos_Horas.Open
BaseMDB.rsTareas.Open
Set xlApp = New Excel.Application
While Not BaseMDB.rsEstructura.EOF
Dir1.Path = c:\" & BaseMDB.rsEstructura!Directorio
File1.Path = Dir1.Path
File1.Pattern = "*.xls"
File1.Refresh
If File1.ListCount > 0 Then
For z = 0 To File1.ListCount - 1
Set xlWB = xlApp.Workbooks.Open(File1.Path & "\" & File1.List(z))
Set rngWS = xlWB.Worksheets(1).Range("A1:K500")
intRows = rngWS.Rows.Count - 1
cNombre = CStr(rngWS.Range("C3").Value)
If Not BaseMDB.rsUsuarios.EOF Then
BaseMDB.rsUsuarios.MoveFirst
End If
lSw = True
lEncuentra = False
While lSw
If BaseMDB.rsUsuarios.EOF Then
lSw = False
Else
If BaseMDB.rsUsuarios!Usuario = Mid(File1.List(z), 1, Len(File1.List(z)) - 4) Then
lEncuentra = True
lSw = False
Else
BaseMDB.rsUsuarios.MoveNext
End If
End If
Wend
If Not lEncuentra Then
BaseMDB.rsUsuarios.AddNew
BaseMDB.rsUsuarios!Usuario = Mid(File1.List(z), 1, Len(File1.List(z)) - 4)
BaseMDB.rsUsuarios!Nombre = cNombre
BaseMDB.rsUsuarios.Update
End If
BaseMDB.rsUsuarios.Requery
If Not BaseMDB.rsUsuarios.EOF Then
BaseMDB.rsUsuarios.MoveFirst
End If
lSw = True
lEncuentra = False
While lSw
If BaseMDB.rsUsuarios.EOF Then
lSw = False
Else
If BaseMDB.rsUsuarios!Usuario = Mid(File1.List(z), 1, Len(File1.List(z)) - 4) Then
lEncuentra = True
lSw = False
Else
BaseMDB.rsUsuarios.MoveNext
End If
End If
Wend
nLugar = BaseMDB.rsUsuarios!ID_Identificador
intRows = rngWS.Rows.Count - 1
For x = 11 To intRows
cComponente = CStr(rngWS.Range("B" & x).Value)
csubcomponente = CStr(rngWS.Range("C" & x).Value)
cSemana = CStr(rngWS.Range("D" & x).Value)
If cComponente & csubcomponente & cSemana = "" Then
x = intRows + 1
Else
If rngWS.Range("E" & x).Value <> " " Then
dFecha = CDate(rngWS.Range("E" & x).Value)
End If
cTarea = CStr(rngWS.Range("F" & x).Value)
cValid = CStr(rngWS.Range("G" & x).Value)
cWorkProduct = CStr(rngWS.Range("H" & x).Value)
cComentarios = CStr(rngWS.Range("I" & x).Value)
cCompleta = CStr(rngWS.Range("J" & x).Value)
cTiempo = CStr(rngWS.Range("K" & x).Value)
For wx = 1 To Len(cTiempo)
If Mid(cTiempo, wx, 1) = "." Then
cTiempo = Mid(rngWS.Range("K" & x).Value, 1, wx - 1) & "," & Mid(rngWS.Range("K" & x).Value, wx + 1, Len(rngWS.Range("K" & x).Value))
End If
Next
If cTiempo <> "" Then
nTiempo = CDbl(cTiempo)
Else
nTiempo = 0
End If
lSw = True
lEncuentra = False
If Not BaseMDB.rsTareas.EOF Then
BaseMDB.rsTareas.MoveFirst
End If
While lSw
If BaseMDB.rsTareas.EOF Then
lSw = False
Else
If BaseMDB.rsTareas!Tarea = cTarea Then
lEncuentra = True
lSw = False
Else
BaseMDB.rsTareas.MoveNext
End If
End If
Wend
If Not lEncuentra Then
BaseMDB.rsTareas.AddNew
BaseMDB.rsTareas!Tarea = cTarea
BaseMDB.rsTareas.Update
End If
nTarea = BaseMDB.rsTareas!ID_Tarea
BaseMDB.rsDatos_Horas.AddNew
BaseMDB.rsDatos_Horas!Componente = cComponente
BaseMDB.rsDatos_Horas!Subcomponente = csubcomponente
BaseMDB.rsDatos_Horas!Fecha = dFecha
BaseMDB.rsDatos_Horas!Tarea = nTarea
BaseMDB.rsDatos_Horas!Valid = cValid
BaseMDB.rsDatos_Horas!WorkProduct = cWorkProduct
BaseMDB.rsDatos_Horas!Comentarios = cComentarios
BaseMDB.rsDatos_Horas!Completa = IIf(Len(cCompleta) > 1, Mid(cCompleta, 1, 1), cCompleta)
BaseMDB.rsDatos_Horas!Tiempo = nTiempo
BaseMDB.rsDatos_Horas!ID_Identificador = nLugar
BaseMDB.rsDatos_Horas!Directorio = BaseMDB.rsEstructura!ID_Estructura
BaseMDB.rsDatos_Horas.Update
End If
Next
xlWB.Close
Set rngWS = Nothing
Set xlWB = Nothing
Next
End If
BaseMDB.rsEstructura.MoveNext
Wend
xlApp.Quit
Set xlApp = Nothing
BaseMDB.rsTareas.Close
BaseMDB.rsDatos_Horas.Close
BaseMDB.rsEstructura.Close
BaseMDB.rsUsuarios.Close
MsgBox "Carga de datos terminada"