Cita:
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
