Extraer datos de una tabla en archivo word y traspasarla a una celda en excel
Tengo una carpeta que posee varios documentos word (aprox 350), que se ubican en diferentes subcarpetas según el área de la empresa. Lo que busco es que, con una macro (si es posible), ingresar a cada documento de las carpetas, buscar específicamente la fecha de última revisión del documento, y esa fecha escribirla en una celda en un archivo excel.
Si no puedo hacer esto, tendré que meterme a los 350 documentos, copiar y pegar la fecha manualmente D=.
1 Respuesta
Documento enviado!
Gracias de antemano.
Saludos,
Esta es la macro para extraer las fechas.
Sub AbrirArchivosWord()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
u = h1.Range("A" & Rows.Count).End(xlUp).Row + 1
h1.Range("A2:D" & u).Clear
'
ruta = ThisWorkbook.Path
ruta = CreateObject("shell.application").browseforfolder(0, _
"Selecciona el Directorio Inical", 0, ruta).items.Item.Path
'
ChDir ruta
archi = Dir("*.doc*")
Do While archi <> ""
cuantos = cuantos + 1
archi = Dir()
Loop
'
archi = Dir("*.doc*")
f = 2
n = 1
Do While archi <> ""
Application.StatusBar = "Archivos procesados: " & n & " De: " & cuantos
h2.Cells.Clear
h2.Columns("A:J").Delete Shift:=xlToLeft
h1.Cells(f, "A") = archi
h1.Cells(f, "D") = ruta
Set DocWord = CreateObject("Word.Application")
'DocWord.Visible = True
'
Set objdoc = DocWord.documents.Open(ruta & "\" & archi)
objdoc.Range.Copy
'
h2.Select
Range("A1").Select
ActiveSheet.Paste
ultima = ""
inicia = False
'
Set b = h2.Cells.Find("VIII", LookAt:=xlPart, SearchDirection:=xlPrevious)
If Not b Is Nothing Then
For i = b.Row To h2.Range("C" & Rows.Count).End(xlUp).Row
If InStr(1, h2.Cells(i, "C"), "Actualiza") > 0 Then
inicia = True
End If
If inicia Then
If h2.Cells(i, "C") = "" Then Exit For
ultima = h2.Cells(i, "C")
End If
Next
If ultima = "" Or InStr(1, ultima, "Actualiza") Then
h1.Cells(f, "B") = "No existen fechas"
Else
h1.Cells(f, "B") = "Última fecha"
h1.Cells(f, "C") = ultima
End If
Else
h1.Cells(f, "B") = "Manejo de versiones no encontrado"
End If
'
f = f + 1
n = n + 1
objdoc.Close
DocWord.Quit
archi = Dir()
Loop
h1.Select
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "Fechas recopiladas"
End SubAntes de ejecutar la macro, revisa las instrucciones:
Instrucciones
1.- Ejecuta la macro por cada carpeta que contenga archivos
2.- Es decir, si tienes 30 carpetas, deberás presionar el botón 30 veces y seleccionar una carpeta a la vez.
3.- Al final del proceso la macro te pondrá, en la hoja1 lo siguiente:
En la columna A el nombre del archivo.
En la columna B el estatus:
- Última fecha, significa que sí encontró la fecha
- No existen fechas, significa que después de la palabra "Actualiza", en el capítulo XIII", no existen fechas
- Manejo de versiones no encontrado, siginifica que no existe el capítulo: "XIII Manejo de versiones"
4.- La hoja2 es necesaria para leer los archivos Word, no la borres
5.- En la columna C la última fecha de actualización
6.- En la columna D la ruta del archivo
