Importar Datos De Excel A Access

[HAIR]

Como Puedo Capturar Determinados Datos De Excel Para Ubicarlos En Campos Especificos De Tablas De Access

[amanda75]

Puedes guardar los datos de excel específicos en un fichero plano separado por tabuladores (.txt). Luego abres access e importas el fichero siguiendo los pasos del asistente. Después puedes hacer una consulta de anexión de datos desde esa nueva tabla a la tabla que te interesa.

[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"

[Fegna]

Como no tienes habilitado el envío por correo, no he podido enviarte el archivo.

Saludos

Fernando

[HAIR]

SALUDOS FERNANDO
PUEDES ENVIARME EL ARCHIVO ADJUNTO A
[email protected]
GRACIAS POR SU COLABORACION

[clara2004]

hola fernando, de dónde eres de argentina?
yo sí, estoy armando lo mismo que hair,
importar datos de excel,
te agradecería si me envias a mí tambien el arc adjuento.
[email protected]

[Fegna]

El archivo se los envié, disculpen la tardanza. Espero que les sirva, si tienen dudas, consúltenme.

No soy argentino, soy chileno, pero eso poco importa en un mundo globalizado donde todos nos podemos ayudar .

Saludos
Fernando

[Fegna]

Hair:

Esto me llegó:

The original message was received at Tue, 20 Jul 2004 10:04:25 -0400
from XXXXXX [YY.YY.YY.YY]

----- The following addresses had permanent fatal errors -----
<[email protected]>
(reason: 550 Error: 550: Spam is not allowed in this site#body#103# #103#)

----- Transcript of session follows -----
... while talking to mx1.latinmail.com.:
>>> DATA
<<< 550 Error: 550: Spam is not allowed in this site#body#103# #103#
554 5.0.0 <[email protected]>... Service unavailable

[Fegna]

He puesto www.geocities.com\fcarvallo\VBExcel.zip como muestra.

Espero que les sirva.

Fernando

[sqa212]

Perdon por la intromision, pero tambien estoy interesado en esto, en el link pone pagina no disponible

[E-Designet]

Iniciado por sqa212

Perdon por la intromision, pero tambien estoy interesado en esto, en el link pone pagina no disponible

Este es el link: http://www.geocities.com/fcarvallo/VBExcel.zip

Pero no entiendo como implementarlo

Salu2.

[aika]

Iniciado por HAIR

Como Puedo Capturar Determinados Datos De Excel Para Ubicarlos En Campos Especificos De Tablas De Access

No se si te servirá lo que he hecho. Resulta que no he encontrado nada satisfactorio ni en Microsoft ni en los foros, así que he automatizado el proceso de importar un Libro de Excel a Tablas Acces.

Como ya he explicado en otro foro, existen condiciones:
- En todas las hojas del libro la primera fila es de cabeceras, es decir, nombres de campo.
- Todas las hojas del libro deben empezar por la columna A y la fila 1
- El programa lee las columnas de la primera fila (fila 1) hasta que encuentra una columna vacía
- El programa lee las filas de cada hoja hasta que encuentra una fila vacía (una fila en la que sus N primeras columnas estén vacías)

Existe una condición adicional si lo que quieres es importar todas las hojas del libro a una misma tabla:
- Todas las hojas del libro deben tener el mismo número de columnas, tener la misma fila de cabecera y ser del mismo tipo de datos

Código:

Option Base 0

Private Type tTablaExcel
   nom(10) As String
   nrow(10) As Integer
   ncol(10) As Integer
End Type

Private Sub cmd_importar_Click()
   Dim dbs As Database, sql As String, tExcel As tTablaExcel, tabla
   Me.campo = OpenCommDlg() 'Esta función muestra un cuadro de diálogo para leer un archivo del disco. No es mia, búscala por ahí.
   If Not IsNull(Me.campo) Then
      tExcel = CreaTablasDeLibroExcel(Me.campo)
      Set dbs = CurrentDb
      For Each tabla In tExcel.nom
         If (tabla = "") Then Exit For
         sql = "INSERT INTO tabla_destino (campo1, campo2, ...)"
         sql = sql & " SELECT campo1, campo2, ..."
         sql = sql & " FROM " & tabla & " AS t ;"
         dbs.Execute sql
         dbs.TableDefs.Delete tabla
      Next
   End If
End Sub

Private Function CreaTablasDeLibroExcel(archivo As String) As tTablaExcel
On Error GoTo ErrSub
   Dim objExcel As Object, hoja As Object, dato As String, columna As Integer, fila As Integer, h As Integer, tipo
   Dim dbs As Database, tdf As TableDef, fld As Field, rs As Recordset
   
   Set dbs = CurrentDb

   ' -- Crea una Nueva instancia de Excel
   Set objExcel = CreateObject("Excel.Application")
   objExcel.Workbooks.Open FileName:=archivo
   
   h = 0
   For Each hoja In objExcel.Worksheets
      CreaTablasDeLibroExcel.nom(h) = "x_" & hoja.Name
      dbs.TableDefs.Delete CreaTablasDeLibroExcel.nom(h)
      Set tdf = dbs.CreateTableDef(CreaTablasDeLibroExcel.nom(h))
      For columna = 0 To 1000
         dato = Trim(hoja.Cells(1, columna + 1))
         If (Nz(dato) <> "") Then
            tipo = TipoDeDato(hoja.Cells(2, columna + 1)) 'Busca en la fila 2 el tipo de dato del campo
            Set fld = tdf.CreateField(dato, tipo)
            tdf.Fields.Append fld
         Else
            CreaTablasDeLibroExcel.ncol(h) = columna
            dbs.TableDefs.Append tdf
            Exit For
         End If
      Next columna
      
      'Cuenta las filas
      Set rs = dbs.OpenRecordset(CreaTablasDeLibroExcel.nom(h), dbOpenDynaset)
      For fila = 0 To 1000
         dato = ""
         'Mira si la fila está vacía
         For columna = 1 To CreaTablasDeLibroExcel.ncol(h)
            dato = Trim(hoja.Cells(fila + 2, columna))
            If (Nz(dato) <> "") Then Exit For
         Next columna
         'Rellena la fila
         If (Nz(dato) <> "") Then
            rs.AddNew
            For columna = 0 To CreaTablasDeLibroExcel.ncol(h) - 1
               Set fld = rs.Fields(columna)
               fld = hoja.Cells(fila + 2, columna + 1)
            Next
            rs.Update
         Else
            CreaTablasDeLibroExcel.nrow(h) = fila
            Exit For
         End If
      Next fila
      
      If (Nz(CreaTablasDeLibroExcel.ncol(h), 0) = 0) Then Exit For
      h = h + 1
   Next
ErrSub:
   If (Err = 3265) Then    'No se encontró el elemento en esta colección
      Resume Next
   ElseIf (Err <> 0) Then
      MsgBox Err.Number & ". " & Err.Description, vbCritical
   End If
   Set fld = Nothing
   Set tdf = Nothing
   Set rs = Nothing
   objExcel.Quit
End Function

Private Function TipoDeDato(dato) As Integer
   Select Case VarType(dato)
      Case vbDate: TipoDeDato = dbDate
      Case vbCurrency: TipoDeDato = dbCurrency
      Case vbInteger, vbByte: TipoDeDato = dbInteger
      Case vbLong, vbSingle, vbDouble, vbDecimal: TipoDeDato = dbLong
      Case Else: TipoDeDato = dbText
   End Select
End Function

Espero que te sirva