¿Como importar con un recordset?
Necesito importar una hoja de un Excel a diario que me llega en los adjuntos de un correo, el tema es que para importarlo necesito importar a partir de la fila 3 ya que la 1 es un titulo y la 2 esta vacía y para más lio la fila 3 que tiene el encabezado en las 3 primeras columnas la filas 2 y 3 tiene las celdas combinadas, por cierto la fila 4 tampoco la tendría que importar y claro me gustaría saber si es posible al hacer la importación la columna D y E que están combinadas darle un nombre ya que como puedes ver comparten encabezado.
¡ Vaya lio ! ¿Cómo lo ves?
Gracias
1 Respuesta
H o l a: Estoy tomando la macro que te envió Sveinbjorn El Rojo
Partiendo de esa macro, cambié la ruta y el nombre del archivo, para posteriormente abrir el archivo y editarlo. En la edición estoy quitando la combinación de celdas, eliminando la fila 4 y las filas 1 y 2; y por último guardo el archivo.
Private Sub NombreBoton_Click()
'Requiere registrar la librería "Microsoft Outlook x.xx Object Library"
' Declara las variables
Dim OlApp As Outlook.Application
Dim Inbox As Outlook.MAPIFolder
Dim InboxItems As Outlook.Items
Dim mail As Object
Dim Adjunto As Outlook.Attachment
Set OlApp = CreateObject("Outlook.Application")
Set Inbox = OlApp.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
Set InboxItems = Inbox.Items
For Each mail In InboxItems
If mail.UnRead Then
If mail.SenderEmailAddress Like "*danteamor*" Then 'Aquí pon la dirección desde la que te envían el Excel
If mail.Attachments.Count > 0 Then
For Each Adjunto In mail.Attachments
'Descargas el adjunto en la misma carpeta del Access. Si quieres otra carpeta, cámbialo
ruta = ThisWorkbook.Path
nombre = Adjunto.Filename
Adjunto.SaveAsFile (ruta & "\" & Adjunto.Filename)
Next
mail.UnRead = False
End If
End If
End If
Next
'Aquí pondrías las líneas para importar los datos
If nombre <> "" Then
Set l2 = Workbooks.Open(ruta & "\" & nombre)
Set h2 = l2.Sheets(1)
h2.Range("D3:E3").UnMerge
h2.Range("E3") = h2.Range("D3")
h2.Rows(4).Delete
h2.Rows(1 & ":" & 2).Delete
l2.Save
l2.Close
Set h2 = Nothing
Set l2 = Nothing
End If
'....
Set OlApp = Nothing
Set Inbox = Nothing
Set InboxItems = Nothing
Set mail = Nothing
Set Adjunto = Nothing
End SubGuarda la macro en un archivo de excel.
Prueba y me comentas.
'S aludos. Dante Amor. Si es lo que necesitas R ecuerda valorar la respuesta. G racias
