Tu Excel tiene más posibilidades.
Menos clics.
Más tiempo.
Cinco macros para quitarte de encima lo repetitivo. Documentos, PDF y filas en orden. Tú pones el libro; ellas hacen el trabajo.
05macros, cero tareas de más
0 €para empezar a usarlas
01hoja Config por libro
100%código abierto a tus cambios
Como en Excel: cada herramienta tiene su hoja.Abre el catálogo ↓
¿Qué vas a dejar
de hacer a mano?
Elige una tarea. Dentro encontrarás su vídeo, la configuración y el código comentado.
N.ºHerramientaHoja
01Enviar documentos personalizadosDocumentos02Dar nombre a PDF numeradosNombres PDF03Comprobar qué registros tienen archivoArchivos04Desglosar un resumen en sus líneasDesglose05Convertir una hoja a otra estructuraEstructuraLas cinco herramientas necesitan el módulo común modUtilidades.bas.
Todo listo para
llevarlo a tu libro.
El paquete incluye las cinco macros, el módulo común, una plantilla de Config y las instrucciones.
El libro de herramientas
Todos los módulos y la guía, en un ZIP.
Descargar paquete →Tu hoja Config
La plantilla para configurar las macros.
Descargar .xlsx →Necesitas Excel de escritorio compatible con VBA. Consulta los requisitos de cada macro antes de usarla.
Tres pasos.
Y una tarea menos.
Importa los módulos.
Abre tu libro en Excel y pulsa Alt + F11. En el editor, ve a Archivo → Importar archivo. Importa modUtilidades.bas y después el módulo de tu herramienta. También puedes copiar el código en Insertar → Módulo.
Prepara la hoja Config.
Crea una hoja llamada
Config: columna A, la clave; columna B, el valor. Cada macro explica las claves que necesita. Puedes partir de la plantilla de configuración.Guarda y ejecuta.
Guarda como Libro habilitado para macros (.xlsm). Pulsa Alt + F8 y elige la macro. Trabaja primero sobre una copia y habilita únicamente macros cuyo código hayas revisado.
Enviar documentos personalizados
Un Word combinado con una página por persona y la hoja con sus datos. La macro saca un PDF por fila, con el nombre que toca, y crea un correo de Outlook con el PDF adjunto. Certificados, facturas, nóminas, cartas, contratos.
Antes
Doce filas con código, nombre, número de documento, importe y correo; un Word ya combinado con doce páginas.
Después
Doce PDF en la carpeta de salida, nombrados con el código y el nombre de cada fila; la columna Estado marcada fila a fila; un correo por fila listo para enviar o revisar; y un registro .tsv de lo que se ha hecho.
Qué problema te resuelve
Cuando tienes que enviar certificados, facturas o cartas a muchas personas, lo pesado es repetir lo mismo: separar cada documento, ponerle nombre, guardarlo y adjuntarlo al correo correcto. Esta macro encadena esos pasos a partir de tu Word combinado y tu lista de Excel.
Por qué te resultará práctica
- Cada PDF sale con su nombre: elige las columnas que lo forman, por ejemplo el código y el nombre del cliente. No tienes que renombrarlos uno a uno.
- Los guarda automáticamente en la carpeta que indiques. Puedes usar la carpeta de ese cliente, campaña o periodo dentro de la organización que ya tienes, sin cambiar las rutas en el código.
- Prepara cada correo con su PDF y personaliza el asunto y el mensaje con los datos de la fila. Puedes revisarlos en Outlook antes de enviarlos o generar solo los documentos.
- Te ayuda a evitar repeticiones: detecta nombres de PDF repetidos antes de empezar y, si configuras la columna Estado, al reanudar omite las filas que ya figuran como ENVIADO.
- Con la columna Estado configurada, guarda el avance en el libro cada cierto número de correos y al terminar. También deja un registro para consultar qué se ha hecho.
Necesita: Excel y Word. Para los correos, Outlook clásico con una cuenta configurada.
Hoja Config: claves que lee esta macro
| Clave (columna A) | Valor (columna B) |
|---|---|
RutaWord | Ruta del Word combinado |
CarpetaPDF | Carpeta de salida de los PDF |
HojaDatos | Hoja con una fila por destinatario |
ColumnaNombre1 / 2 | Columnas que forman el nombre del PDF |
ColumnaCorreo | Columna con el correo |
ColumnaEstado | Opcional: columna de estado (permite reanudar) |
Asunto | Asunto; admite {columna} |
ModoEnvio | ENVIAR, MOSTRAR o NINGUNO |
Código · macros GenerarYEnviar, GenerarYMostrarCorreos, GenerarSoloPDF
Importa este módulo y modUtilidades (Alt+F11 → Archivo → Importar). Los comentarios >> ADAPTAR marcan los puntos pensados para cambiar.
Option Explicit
' =====================================================================
' modCombinarEnviar - Word combinado -> un PDF por pagina -> correo Outlook
'
' QUE HACE
' Sirve para cualquier envio masivo de documentos personalizados:
' certificados, facturas, nominas, cartas, contratos... Partes de una
' combinacion de correspondencia de Word (UNA pagina por destinatario,
' en el mismo orden que las filas) y de la hoja Excel con sus datos.
' La macro exporta cada pagina a un PDF con el nombre de su fila, lo
' guarda en la carpeta de salida y (si quieres) crea un correo de
' Outlook por fila con el PDF adjunto.
'
' COMO USARLA
' 1. Importa modUtilidades.bas y este modulo (Alt+F11 > Importar).
' Guarda el libro como .xlsm.
' 2. Hoja "Config" (A = clave, B = valor):
' RutaWord C:\Envios\Cartas combinadas.docx (obligatoria)
' CarpetaPDF C:\Envios\Salida (obligatoria)
' HojaDatos Datos (obligatoria)
' ColumnaNombre1 A 1a parte del nombre del PDF (ej. codigo)
' ColumnaNombre2 B 2a parte del nombre del PDF (ej. nombre)
' ColumnaCorreo E (obligatoria) correo del destinatario
' ColumnaCC F opcional, copia
' ColumnaEstado G opcional; permite reanudar
' Asunto Factura {C} - {B} (obligatoria)
' Remitente facturacion@tuempresa.com opcional
' ModoEnvio MOSTRAR ENVIAR | MOSTRAR (abre sin enviar) | NINGUNO (solo PDF)
' PrimeraFila 2 UltimaFila (vacio = todas)
' SobrescribirPDF SI GuardarCada 25 EvitarAvisosOLE SI
' 3. Hoja "Plantilla": en la columna A, el cuerpo HTML del correo.
' Admite marcadores {A}, {B}, {AO}... con el valor de esa columna.
' 4. Ejecuta GenerarYEnviar, GenerarYMostrarCorreos o GenerarSoloPDF.
'
' LO QUE LA HACE SEGURA
' - Reanudable: escribe el estado en ColumnaEstado y salta las filas ya
' marcadas ENVIADO. Repetirla tras un fallo no reenvia nada.
' - Comprueba antes de empezar: paginas = filas, nombres repetidos,
' errores de Excel, rutas demasiado largas.
' - Usa su propia instancia de Word (no toca la que tengas abierta) y
' deja un registro TSV de cada PDF y cada correo.
'
' PARA ADAPTARLA (busca ">> ADAPTAR")
' - Anadir CCO, importancia o firma en EnviarUno.
' - Adjuntar un segundo archivo fijo (condiciones, folleto).
' - Cambiar el formato del nombre del PDF.
' Requiere: modUtilidades. Necesita Word y, para enviar, Outlook clasico
' con una cuenta configurada.
' =====================================================================
#If VBA7 Then
Private Declare PtrSafe Function CoRegisterMessageFilter Lib "ole32.dll" ( _
ByVal filtroNuevo As LongPtr, ByRef filtroAnterior As LongPtr) As Long
Private Declare PtrSafe Sub IUnknown_AtomicRelease Lib "shlwapi.dll" (ByRef interfaz As LongPtr)
Private mFiltroOLEAnterior As LongPtr
#Else
Private Declare Function CoRegisterMessageFilter Lib "ole32.dll" ( _
ByVal filtroNuevo As Long, ByRef filtroAnterior As Long) As Long
Private Declare Sub IUnknown_AtomicRelease Lib "shlwapi.dll" (ByRef interfaz As Long)
Private mFiltroOLEAnterior As Long
#End If
Private mFiltroOLESuspendido As Boolean
Private mEnCurso As Boolean
Private Const PREFIJO_TEMPORAL As String = "CombinarEnviar_"
Private Type Configuracion
RutaWord As String
CarpetaPDF As String
HojaDatos As String
ColNombre1 As Long
ColNombre2 As Long
ColCorreo As Long
ColCC As Long ' 0 = sin copia
ColEstado As Long ' 0 = sin reanudacion
Remitente As String
Asunto As String
PrimeraFila As Long
UltimaFila As Long ' 0 = hasta la ultima fila con datos
Sobrescribir As Boolean
ModoEnvio As String ' ENVIAR | MOSTRAR | NINGUNO
GuardarCada As Long ' guardar el libro cada N correos (0 = solo al final)
EvitarAvisosOLE As Boolean
End Type
' ---------- Puntos de entrada ----------
Public Sub GenerarYEnviar()
Ejecutar ""
End Sub
Public Sub GenerarSoloPDF()
Ejecutar "NINGUNO"
End Sub
Public Sub GenerarYMostrarCorreos()
Ejecutar "MOSTRAR"
End Sub
' ---------- Motor ----------
Private Sub Ejecutar(ByVal forzarModo As String)
Dim cfg As Configuracion, est As EstadoExcel
Dim ws As Worksheet, fso As Object, nombresVistos As Object
Dim wordApp As Object, wordDoc As Object, outlookApp As Object
Dim datos As Variant, nombres() As String, correos() As String, copias() As String, pendientes() As Boolean
Dim ultima As Long, total As Long, primero As Long, ultimo As Long, p As Long, paginas As Long, ancho As Long
Dim copiados As Long, entregados As Long, sinCorreo As Long, saltados As Long, desdeGuardado As Long
Dim temporal As String, dirPaginas As String, dirNombres As String, registro As String, registroDestino As String
Dim origen As String, localNombrado As String, destino As String, html As String, asunto As String
Dim fase As String, errorTexto As String, inicio As Date, completo As Boolean, mensaje As String, limpieza As String
Dim opcionesWord() As Boolean, opcionesWordGuardadas As Boolean
ReDim opcionesWord(0 To 2)
Dim segPDF As Double, segCopia As Double, segCorreo As Double, marca As Double
If mEnCurso Then Exit Sub
mEnCurso = True
On Error GoTo Fallo
inicio = Now
fase = "Leer configuracion"
cfg = LeerConfiguracion()
If Len(forzarModo) > 0 Then cfg.ModoEnvio = forzarModo
Set ws = ThisWorkbook.Worksheets(cfg.HojaDatos)
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(cfg.CarpetaPDF) Then Err.Raise vbObjectError + 100, , "No existe la carpeta de salida: " & cfg.CarpetaPDF
If Not (LCase$(Left$(cfg.RutaWord, 4)) = "http") Then
If Not fso.FileExists(cfg.RutaWord) Then Err.Raise vbObjectError + 101, , "No existe el Word combinado: " & cfg.RutaWord
End If
fase = "Validar datos"
ultima = UltimaFila(ws, cfg.ColNombre1)
If ultima < 2 Then Err.Raise vbObjectError + 102, , "No hay filas de datos."
total = ultima - 1
primero = cfg.PrimeraFila - 1
ultimo = IIf(cfg.UltimaFila = 0, total, cfg.UltimaFila - 1)
If primero < 1 Or ultimo < primero Or ultimo > total Then Err.Raise vbObjectError + 103, , "El intervalo de filas del lote no es valido."
ReDim nombres(1 To total): ReDim correos(1 To total): ReDim copias(1 To total): ReDim pendientes(1 To total)
Set nombresVistos = CreateObject("Scripting.Dictionary")
nombresVistos.CompareMode = vbTextCompare
For p = primero To ultimo
If IsError(ws.Cells(p + 1, cfg.ColNombre1).Value) Or IsError(ws.Cells(p + 1, cfg.ColNombre2).Value) Or IsError(ws.Cells(p + 1, cfg.ColCorreo).Value) Then
Err.Raise vbObjectError + 104, , "Hay un error de Excel en la fila " & p + 1
End If
' >> ADAPTAR: nombre del PDF = "<col1> <col2>.pdf". Para anadir una tercera parte o la
' fecha: NombreArchivoSeguro("pdf", ws.Cells(p + 1, cfg.ColNombre1).Value, Format$(Date, "yyyy-mm"))
nombres(p) = NombreArchivoSeguro("pdf", ws.Cells(p + 1, cfg.ColNombre1).Value, ws.Cells(p + 1, cfg.ColNombre2).Value)
correos(p) = Trim$(CStr(ws.Cells(p + 1, cfg.ColCorreo).Value))
If cfg.ColCC > 0 Then copias(p) = Trim$(CStr(ws.Cells(p + 1, cfg.ColCC).Value))
If nombresVistos.Exists(nombres(p)) Then
Err.Raise vbObjectError + 105, , "Nombre PDF repetido en filas " & nombresVistos(nombres(p)) & " y " & p + 1 & ": " & nombres(p)
End If
nombresVistos.Add nombres(p), p + 1
destino = fso.BuildPath(cfg.CarpetaPDF, nombres(p))
If Len(destino) > 240 Then Err.Raise vbObjectError + 106, , "Ruta demasiado larga en fila " & p + 1
' Reanudacion: una fila marcada ENVIADO no se vuelve a tocar.
pendientes(p) = True
If cfg.ColEstado > 0 Then
If UCase$(Left$(Trim$(CStr(ws.Cells(p + 1, cfg.ColEstado).Value)), 7)) = "ENVIADO" Then
pendientes(p) = False: saltados = saltados + 1
End If
End If
If pendientes(p) And Not cfg.Sobrescribir Then
If fso.FileExists(destino) Then Err.Raise vbObjectError + 107, , "Ya existe: " & destino
End If
Next p
p = 0
fase = "Preparar temporales"
temporal = fso.BuildPath(fso.GetSpecialFolder(2).Path, PREFIJO_TEMPORAL & fso.GetTempName)
fso.CreateFolder temporal
dirPaginas = fso.BuildPath(temporal, "paginas"): fso.CreateFolder dirPaginas
dirNombres = fso.BuildPath(temporal, "nombrados"): fso.CreateFolder dirNombres
registro = fso.BuildPath(temporal, "registro.tsv")
registroDestino = fso.BuildPath(cfg.CarpetaPDF, "registro_" & Format$(inicio, "yyyymmdd_hhnnss") & ".tsv")
RegistroCrear fso, registro
RegistroAnotar fso, registro, 0, "INICIO", "", "", "Word: " & cfg.RutaWord & " | modo: " & cfg.ModoEnvio & " | saltadas por ENVIADO: " & saltados
GuardarEstado est
html = LeerPlantillaHTML()
fase = "Abrir y paginar Word"
Application.StatusBar = fase
If cfg.EvitarAvisosOLE Then SuspenderAvisosOLE
Set wordApp = CreateObject("Word.Application") ' instancia propia, nunca la del usuario
wordApp.Visible = False
wordApp.ScreenUpdating = False
opcionesWord(0) = wordApp.Options.Pagination
opcionesWord(1) = wordApp.Options.CheckSpellingAsYouType
opcionesWord(2) = wordApp.Options.CheckGrammarAsYouType
opcionesWordGuardadas = True
wordApp.Options.CheckSpellingAsYouType = False
wordApp.Options.CheckGrammarAsYouType = False
Set wordDoc = wordApp.Documents.Open(cfg.RutaWord, False, True, False)
wordDoc.Repaginate
paginas = wordDoc.ComputeStatistics(2) ' wdStatisticPages
If paginas <> total Then
Err.Raise vbObjectError + 108, , "Word tiene " & paginas & " paginas y Excel " & total & " filas de datos. Se requiere una pagina por fila y el mismo orden."
End If
ancho = Len(CStr(total))
On Error Resume Next
wordApp.Options.Pagination = False
On Error GoTo Fallo
fase = "Exportar paginas a PDF"
For p = primero To ultimo
If pendientes(p) Then
marca = CDbl(Timer)
origen = fso.BuildPath(dirPaginas, "pagina-" & Format$(p, String$(ancho, "0")) & ".pdf")
' PDF=17, calidad impresion=0, wdExportFromTo=3. Pagina p = fila p+1.
wordDoc.ExportAsFixedFormat origen, 17, False, 0, 3, p, p
ComprobarArchivoExiste fso, origen
segPDF = segPDF + SegundosDesde(marca)
marca = CDbl(Timer)
localNombrado = fso.BuildPath(dirNombres, nombres(p))
destino = fso.BuildPath(cfg.CarpetaPDF, nombres(p))
fso.MoveFile origen, localNombrado
fso.CopyFile localNombrado, destino, cfg.Sobrescribir
ComprobarArchivoExiste fso, destino
If fso.GetFile(localNombrado).Size <> fso.GetFile(destino).Size Then Err.Raise vbObjectError + 111, , "La copia no tiene el tamano esperado: " & destino
copiados = copiados + 1
If cfg.ColEstado > 0 Then ws.Cells(p + 1, cfg.ColEstado).Value = "PDF " & Format$(Now, "yyyy-mm-dd hh:nn")
RegistroAnotar fso, registro, p + 1, "PDF_OK", correos(p), destino, ""
segCopia = segCopia + SegundosDesde(marca)
End If
Progreso "PDF guardados", p - primero + 1, ultimo - primero + 1
Next p
p = 0
fase = "Cerrar Word"
wordDoc.Close False: Set wordDoc = Nothing
RestaurarWord wordApp, opcionesWord: opcionesWordGuardadas = False
wordApp.Quit False: Set wordApp = Nothing
RestaurarAvisosOLE
RegistroAnotar fso, registro, 0, "GENERACION_OK", "", "", Format$(segPDF, "0.0") & " s PDF; " & Format$(segCopia, "0.0") & " s copia"
If cfg.ModoEnvio <> "NINGUNO" Then
fase = "Conectar con Outlook"
Set outlookApp = ObtenerOutlook()
fase = "Correos"
marca = CDbl(Timer)
For p = primero To ultimo
If pendientes(p) Then
destino = fso.BuildPath(cfg.CarpetaPDF, nombres(p))
If Len(correos(p)) > 0 Then
asunto = RellenarPlantilla(cfg.Asunto, ws, p + 1)
RegistroAnotar fso, registro, p + 1, "INTENTO_" & cfg.ModoEnvio, correos(p), destino, ""
EnviarUno outlookApp, correos(p), copias(p), cfg.Remitente, asunto, _
RellenarPlantilla(html, ws, p + 1), fso.BuildPath(dirNombres, nombres(p)), cfg.ModoEnvio
entregados = entregados + 1
If cfg.ColEstado > 0 Then
ws.Cells(p + 1, cfg.ColEstado).Value = IIf(cfg.ModoEnvio = "ENVIAR", "ENVIADO ", "MOSTRADO ") & Format$(Now, "yyyy-mm-dd hh:nn")
desdeGuardado = desdeGuardado + 1
If cfg.GuardarCada > 0 And desdeGuardado >= cfg.GuardarCada Then
ThisWorkbook.Save: desdeGuardado = 0
End If
End If
RegistroAnotar fso, registro, p + 1, "ENTREGADO_A_OUTLOOK", correos(p), destino, asunto
Else
sinCorreo = sinCorreo + 1
If cfg.ColEstado > 0 Then ws.Cells(p + 1, cfg.ColEstado).Value = "SIN CORREO"
RegistroAnotar fso, registro, p + 1, "SIN_CORREO", "", destino, ""
End If
End If
Progreso "Correos", p - primero + 1, ultimo - primero + 1
Next p
p = 0
segCorreo = SegundosDesde(marca)
RegistroAnotar fso, registro, 0, "CORREO_OK", "", "", Format$(segCorreo, "0.0") & " s"
End If
RegistroAnotar fso, registro, 0, "FIN", "", "", "Duracion total: " & DateDiff("s", inicio, Now) & " s"
completo = True
GoTo Salida
Fallo:
errorTexto = "Error " & Err.Number & " en '" & fase & "': " & Err.Description
If p >= 1 And p <= total Then errorTexto = errorTexto & " (fila " & p + 1 & ")"
On Error Resume Next
RegistroAnotar fso, registro, IIf(p >= 1 And p <= total, p + 1, 0), "ERROR", "", "", errorTexto
On Error GoTo 0
Salida:
On Error Resume Next
If Not wordDoc Is Nothing Then wordDoc.Close False
If opcionesWordGuardadas Then RestaurarWord wordApp, opcionesWord
If Not wordApp Is Nothing Then wordApp.Quit False
Set wordDoc = Nothing: Set wordApp = Nothing: Set outlookApp = Nothing
Err.Clear
RestaurarAvisosOLE
If Err.Number <> 0 Then
completo = False
errorTexto = errorTexto & vbCrLf & "No se pudo restaurar el filtro OLE: " & Err.Description & ". Guarda y reinicia Excel antes de otro lote."
End If
If cfg.ColEstado > 0 And entregados > 0 Then ThisWorkbook.Save
RestaurarEstado est
On Error GoTo 0
mEnCurso = False
If Len(registro) > 0 Then
On Error Resume Next
Err.Clear
fso.CopyFile registro, registroDestino, False
If Err.Number = 0 Then registro = registroDestino Else errorTexto = errorTexto & vbCrLf & "El registro se conserva en: " & registro
On Error GoTo 0
End If
mensaje = "PDF guardados: " & copiados & vbCrLf & _
"Correos (" & cfg.ModoEnvio & "): " & entregados & vbCrLf & _
"Filas sin correo: " & sinCorreo & vbCrLf & _
"Filas saltadas por estar ya ENVIADAS: " & saltados & vbCrLf & _
"Tiempos: PDF " & Format$(segPDF, "0.0") & " s, copia " & Format$(segCopia, "0.0") & " s, Outlook " & Format$(segCorreo, "0.0") & " s"
If completo Then
limpieza = LimpiarTemporal(fso, temporal)
mensaje = "Proceso terminado." & vbCrLf & mensaje & IIf(Len(limpieza) > 0, vbCrLf & limpieza, "")
Else
mensaje = errorTexto & vbCrLf & mensaje & vbCrLf & "Temporales conservados: " & temporal & vbCrLf & _
"Vuelve a ejecutar la macro: las filas marcadas ENVIADO no se repiten."
End If
If Len(registro) > 0 Then mensaje = mensaje & vbCrLf & "Registro: " & registro
Aviso mensaje, IIf(completo, vbInformation, vbExclamation)
End Sub
' ---------- Configuracion ----------
Private Function LeerConfiguracion() As Configuracion
Dim c As Configuracion
c.RutaWord = LeerConfig("RutaWord")
c.CarpetaPDF = LeerConfig("CarpetaPDF")
c.HojaDatos = LeerConfig("HojaDatos")
c.ColNombre1 = ColumnaANumero(LeerConfig("ColumnaNombre1", False, "A"))
c.ColNombre2 = ColumnaANumero(LeerConfig("ColumnaNombre2", False, "B"))
c.ColCorreo = ColumnaANumero(LeerConfig("ColumnaCorreo"))
If Len(LeerConfig("ColumnaCC", False)) > 0 Then c.ColCC = ColumnaANumero(LeerConfig("ColumnaCC", False))
If Len(LeerConfig("ColumnaEstado", False)) > 0 Then c.ColEstado = ColumnaANumero(LeerConfig("ColumnaEstado", False))
c.Remitente = LeerConfig("Remitente", False)
c.Asunto = LeerConfig("Asunto")
c.PrimeraFila = ConfigLong("PrimeraFila", 2)
c.UltimaFila = ConfigLong("UltimaFila", 0)
c.Sobrescribir = ConfigBool("SobrescribirPDF", True)
c.ModoEnvio = UCase$(LeerConfig("ModoEnvio", False, "MOSTRAR"))
If c.ModoEnvio <> "ENVIAR" And c.ModoEnvio <> "MOSTRAR" And c.ModoEnvio <> "NINGUNO" Then
Err.Raise vbObjectError + 3, , "ModoEnvio debe ser ENVIAR, MOSTRAR o NINGUNO."
End If
c.GuardarCada = ConfigLong("GuardarCada", 25)
c.EvitarAvisosOLE = ConfigBool("EvitarAvisosOLE", True)
If c.PrimeraFila < 2 Then Err.Raise vbObjectError + 4, , "PrimeraFila debe ser 2 o mayor (la fila 1 son cabeceras)."
LeerConfiguracion = c
End Function
Private Function LeerPlantillaHTML() As String
Dim ws As Worksheet, r As Long, s As String
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Plantilla")
On Error GoTo 0
If ws Is Nothing Then Err.Raise vbObjectError + 5, , "Falta la hoja 'Plantilla' con el cuerpo HTML del correo en la columna A."
For r = 1 To UltimaFila(ws, 1)
s = s & CStr(ws.Cells(r, 1).Value) & vbCrLf
Next r
If Len(Trim$(s)) = 0 Then Err.Raise vbObjectError + 6, , "La hoja 'Plantilla' esta vacia."
LeerPlantillaHTML = s
End Function
' ---------- Outlook ----------
Private Sub EnviarUno(ByVal app As Object, ByVal destinatario As String, ByVal cc As String, ByVal remitente As String, _
ByVal asunto As String, ByVal html As String, ByVal adjunto As String, ByVal modo As String)
Dim mail As Object
Set mail = app.CreateItem(0)
With mail
.To = destinatario
If Len(cc) > 0 Then .CC = cc
If Len(remitente) > 0 Then .SentOnBehalfOfName = remitente
.Subject = asunto
.HTMLBody = html
.Attachments.Add adjunto
' >> ADAPTAR: aqui se personaliza el correo. Ejemplos:
' .BCC = "archivo@tuempresa.com" copia oculta fija
' .Importance = 2 alta (0 baja, 1 normal)
' .Attachments.Add "C:\Envios\Condiciones.pdf" segundo adjunto fijo
' .ReadReceiptRequested = True acuse de recibo
' Para la firma de Outlook: usa .Display antes de .HTMLBody y concatena
' html & .HTMLBody (la firma se inserta al mostrar el correo).
If modo = "ENVIAR" Then .Send Else .Display
End With
Set mail = Nothing
End Sub
' ---------- Word ----------
Private Sub RestaurarWord(ByVal app As Object, ByRef opciones() As Boolean)
On Error Resume Next
app.Options.Pagination = opciones(0)
app.Options.CheckSpellingAsYouType = opciones(1)
app.Options.CheckGrammarAsYouType = opciones(2)
On Error GoTo 0
End Sub
' ---------- Filtro OLE ("Excel esta esperando a otra aplicacion") ----------
Private Sub SuspenderAvisosOLE()
If mFiltroOLESuspendido Then Err.Raise vbObjectError + 130, , "El filtro OLE de una ejecucion anterior sigue suspendido. Reinicia Excel."
If CoRegisterMessageFilter(0, mFiltroOLEAnterior) <> 0 Then Err.Raise vbObjectError + 131, , "No se pudo suspender el filtro OLE."
mFiltroOLESuspendido = True
End Sub
Private Sub RestaurarAvisosOLE()
#If VBA7 Then
Dim retirado As LongPtr
#Else
Dim retirado As Long
#End If
If Not mFiltroOLESuspendido Then Exit Sub
If CoRegisterMessageFilter(mFiltroOLEAnterior, retirado) <> 0 Then Err.Raise vbObjectError + 132, , "CoRegisterMessageFilter fallo al restaurar."
mFiltroOLESuspendido = False
IUnknown_AtomicRelease retirado
IUnknown_AtomicRelease mFiltroOLEAnterior
End Sub
' ---------- Temporales ----------
Private Function LimpiarTemporal(ByVal fso As Object, ByVal carpeta As String) As String
Dim ruta As String
On Error GoTo NoBorrado
ruta = fso.GetAbsolutePathName(carpeta)
If StrComp(fso.GetParentFolderName(ruta), fso.GetAbsolutePathName(fso.GetSpecialFolder(2).Path), vbTextCompare) <> 0 Then GoTo NoBorrado
If Left$(fso.GetFileName(ruta), Len(PREFIJO_TEMPORAL)) <> PREFIJO_TEMPORAL Then GoTo NoBorrado
fso.DeleteFolder ruta, True
Exit Function
NoBorrado:
LimpiarTemporal = "No se elimino la carpeta temporal: " & carpeta
End Function
Dar nombre a PDF numerados
Una carpeta con PDF numerados (pagina-1, pagina-2…, lo que sale de dividir un documento grande) y dos columnas de Excel en el mismo orden. La macro copia cada PDF con su nombre y deja una tabla de correspondencia.
Antes
25 PDF llamados pagina-1.pdf … pagina-25.pdf y una hoja con código y nombre, 25 filas.
Después
Una carpeta nueva con 25 copias, cada una con su código y nombre; los originales intactos; y correspondencia.tsv (página → fila → archivo).
Qué problema te resuelve
Has dividido un documento y ahora tienes una carpeta llena de pagina-1, pagina-2… Para saber de quién es cada PDF tendrías que abrirlo y renombrarlo. Si tienes una lista de Excel en el mismo orden, la macro utiliza esa lista para ponerles un nombre útil de una sola vez.
Por qué te resultará práctica
- Forma cada nombre con dos columnas de tu hoja, por ejemplo número de expediente y nombre. Así puedes reconocer los archivos sin abrirlos.
- Tú eliges dónde dejarlos: dentro de la carpeta de tu departamento, cliente o año. Crea allí una subcarpeta con fecha y hora y guarda las copias ya nombradas.
- Conserva los originales. Si necesitas comprobar algo o volver a empezar, sigues teniendo los PDF tal como llegaron.
- Antes de copiar, avisa si faltan páginas, hay números o nombres repetidos, o un PDF no supera las comprobaciones. También te muestra ejemplos para que confirmes que la lista está en el orden correcto.
- Deja una relación entre el nombre antiguo y el nuevo para seguir el rastro de cada documento. Puedes guardar las rutas en Config y reutilizarlas en el siguiente lote.
Necesita: Excel. Sin Config, la macro pregunta todo con diálogos.
Hoja Config: claves que lee esta macro
| Clave (columna A) | Valor (columna B) |
|---|---|
CarpetaOrigenPDF | Carpeta con los PDF numerados |
PaginasEsperadas | Cuántos PDF debe haber |
RangoDatos | Hoja!A2:B26 — 2 columnas sin cabecera |
CarpetaDestinoPDF | Dónde crear la carpeta de copias |
PrefijoPDF | Prefijo del nombre de origen (pagina-) |
Código · macro RecuperarPDFsPorNombre
Importa este módulo y modUtilidades (Alt+F11 → Archivo → Importar). Los comentarios >> ADAPTAR marcan los puntos pensados para cambiar.
Option Explicit
' =====================================================================
' modRenombrarPDFs - Dar nombre a una carpeta de PDF numerados
'
' QUE HACE
' Tienes una carpeta con PDF numerados ("pagina-1.pdf", "pagina-2.pdf"...
' por ejemplo el resultado de dividir un documento grande) y una hoja
' con dos columnas (codigo + nombre, numero + concepto...) en el mismo
' orden. La macro copia cada PDF a una carpeta nueva con el nombre
' formado por esas dos columnas y deja un archivo correspondencia.tsv
' (pagina -> fila -> archivo). COPIA, nunca mueve: los originales quedan
' intactos. Antes de copiar comprueba que no falta ninguna pagina, que
' ningun nombre se repite y que cada PDF esta completo.
'
' COMO USARLA
' 1. Importa modUtilidades.bas y este modulo (Alt+F11 > Importar).
' 2. Ejecuta RecuperarPDFsPorNombre (Alt+F8). Sin configuracion, la
' macro pregunta con dialogos: carpeta de PDF, numero esperado de
' paginas, rango de 2 columnas y carpeta de destino.
' 3. Para no preguntar nada (lotes repetidos), hoja "Config":
' CarpetaOrigenPDF C:\Escaneos\paginas
' PaginasEsperadas 25
' RangoDatos Nombres!A2:B26 (2 columnas, sin cabecera)
' CarpetaDestinoPDF C:\Escaneos
' PrefijoPDF pagina- (vacio = "pagina-")
'
' PARA ADAPTARLA (busca ">> ADAPTAR")
' - Otro patron de nombre de origen (p. ej. "escaneo_001.pdf").
' - Tres columnas en el nombre, o un separador distinto del espacio.
' - Mover en lugar de copiar (no recomendado sin copia de seguridad).
' Requiere: modUtilidades.
' =====================================================================
Private mEnCurso As Boolean
Public Sub RecuperarPDFsPorNombre()
Dim fso As Object, patron As Object, m As Object, archivos As Object, archivo As Object, nombresVistos As Object
Dim seleccion As Range, datos As Variant, nombres() As String
Dim origen As String, baseDestino As String, destino As String, ruta As String, errorTexto As String, respuesta As String
Dim total As Long, esperado As Long, numero As Long, p As Long, copiados As Long
Dim registro As Object, est As EstadoExcel, completo As Boolean
If mEnCurso Then Exit Sub
mEnCurso = True
On Error GoTo Fallo
Set fso = CreateObject("Scripting.FileSystemObject")
' Si la hoja Config tiene CarpetaOrigenPDF, RangoDatos y CarpetaDestinoPDF no se pregunta nada.
origen = LeerConfig("CarpetaOrigenPDF", False)
If Len(origen) = 0 Then origen = ElegirCarpeta("Selecciona la carpeta con los PDF numerados")
If Len(origen) = 0 Then GoTo Salida
' 1) Inventario de <prefijo>N.pdf
' >> ADAPTAR: el patron del nombre de origen. Por defecto "pagina-1.pdf", "pagina-2.pdf"...
' El prefijo se puede cambiar en Config (PrefijoPDF). Para otro esquema cambia la
' expresion regular: p. ej. "^escaneo_0*([0-9]{1,7})\.pdf$" admite "escaneo_001.pdf".
Set patron = CreateObject("VBScript.RegExp")
patron.Pattern = "^" & EscaparRegExp(LeerConfig("PrefijoPDF", False, "pagina-")) & "0*([0-9]{1,7})\.pdf$"
patron.IgnoreCase = True
Set archivos = CreateObject("Scripting.Dictionary")
For Each archivo In fso.GetFolder(origen).Files
Set m = patron.Execute(archivo.Name)
If m.Count > 0 Then
numero = CLng(m(0).SubMatches(0))
If numero < 1 Then Err.Raise vbObjectError + 201, , "Numero de pagina no valido: " & archivo.Name
If archivos.Exists(numero) Then Err.Raise vbObjectError + 202, , "Dos archivos con el numero " & numero
archivos.Add numero, archivo.Path
If numero > total Then total = numero
ElseIf LCase$(fso.GetExtensionName(archivo.Name)) = "pdf" Then
Err.Raise vbObjectError + 203, , "PDF con nombre inesperado: " & archivo.Name & ". Deja en la carpeta solo los PDF numerados."
End If
Next archivo
If total = 0 Then Err.Raise vbObjectError + 204, , "No se encontraron archivos pagina-N.pdf."
For p = 1 To total
If Not archivos.Exists(p) Then Err.Raise vbObjectError + 205, , "Falta la pagina " & p & ". No se ha copiado nada."
Next p
' 2) Confirmar el numero esperado (antes era una constante fija)
respuesta = LeerConfig("PaginasEsperadas", False)
If Len(respuesta) = 0 Then respuesta = InputBox("Se han encontrado " & total & " PDF numerados del 1 al " & total & "." & vbCrLf & _
"Escribe el numero de paginas que esperas para confirmar:", "Confirmar paginas", CStr(total))
If Len(respuesta) = 0 Then GoTo Salida
If Not IsNumeric(respuesta) Then Err.Raise vbObjectError + 216, , "Numero no valido."
esperado = CLng(respuesta)
If esperado <> total Then Err.Raise vbObjectError + 216, , "Esperabas " & esperado & " y hay " & total & ". Revisa la carpeta."
' 3) Rango del Excel ORIGINAL (el usuario lo elige; nunca se toma el libro activo a ciegas)
On Error Resume Next
If Len(LeerConfig("RangoDatos", False)) > 0 Then
Set seleccion = ThisWorkbook.Worksheets(Split(LeerConfig("RangoDatos", False), "!")(0)).Range(Split(LeerConfig("RangoDatos", False), "!")(1))
Else
Set seleccion = Application.InputBox( _
Prompt:="Selecciona A2:B" & total + 1 & " con los datos, en el mismo orden que los PDF.", _
Title:="Datos para nombrar los PDF", Type:=8)
End If
On Error GoTo Fallo
If seleccion Is Nothing Then GoTo Salida
If seleccion.Areas.Count <> 1 Or seleccion.Columns.Count <> 2 Or seleccion.Rows.Count <> total Then
Err.Raise vbObjectError + 206, , "Selecciona exactamente " & total & " filas y 2 columnas, sin cabeceras."
End If
datos = seleccion.Value
ReDim nombres(1 To total)
Set nombresVistos = CreateObject("Scripting.Dictionary")
nombresVistos.CompareMode = vbTextCompare
baseDestino = LeerConfig("CarpetaDestinoPDF", False)
If Len(baseDestino) = 0 Then baseDestino = ElegirCarpeta("Elige donde crear la carpeta de PDF recuperados")
If Len(baseDestino) = 0 Then GoTo Salida
destino = fso.BuildPath(baseDestino, "Recuperados_" & Format$(Now, "yyyymmdd_hhnnss"))
For p = 1 To total
If IsError(datos(p, 1)) Or IsError(datos(p, 2)) Then Err.Raise vbObjectError + 207, , "Error de Excel en la fila " & p + 1
If Len(Trim$(CStr(datos(p, 1)))) = 0 Or Len(Trim$(CStr(datos(p, 2)))) = 0 Then Err.Raise vbObjectError + 208, , "Celda vacia en la fila " & p + 1
' >> ADAPTAR: el nombre final. NombreArchivoSeguro une las partes con un espacio y
' quita los caracteres no validos. Para tres columnas, selecciona 3 columnas
' (cambia el "Columns.Count <> 2" de arriba) y pasa datos(p, 3) como tercera parte.
' Para un separador distinto: NombreArchivoSeguro("pdf", datos(p, 1) & "_" & datos(p, 2))
nombres(p) = NombreArchivoSeguro("pdf", datos(p, 1), datos(p, 2))
If nombresVistos.Exists(nombres(p)) Then
Err.Raise vbObjectError + 209, , "Nombre repetido en filas " & nombresVistos(nombres(p)) & " y " & p + 1 & ": " & nombres(p)
End If
nombresVistos.Add nombres(p), p + 1
If Len(fso.BuildPath(destino, nombres(p))) > 240 Then Err.Raise vbObjectError + 210, , "Ruta demasiado larga para: " & nombres(p)
ComprobarPDF CStr(archivos(p))
Next p
p = 0
If Not Confirmar("Se copiaran " & total & " PDF conservando los originales." & vbCrLf & vbCrLf & _
"Pagina 1 -> " & Left$(nombres(1), 90) & vbCrLf & _
"Pagina " & (total + 1) \ 2 & " -> " & Left$(nombres((total + 1) \ 2), 90) & vbCrLf & _
"Pagina " & total & " -> " & Left$(nombres(total), 90) & vbCrLf & vbCrLf & _
"Confirma que las muestras corresponden a esos PDF.", "Comprobar") Then GoTo Salida
GuardarEstado est
fso.CreateFolder destino
Set registro = fso.CreateTextFile(fso.BuildPath(destino, "correspondencia.tsv"), False, True)
registro.WriteLine "Pagina" & vbTab & "FilaExcel" & vbTab & "Original" & vbTab & "Nombrado"
For p = 1 To total
ruta = fso.BuildPath(destino, nombres(p))
' >> ADAPTAR: se COPIA para conservar los originales. Si de verdad quieres moverlos,
' sustituye por fso.MoveFile y quita la comprobacion de tamano de la linea siguiente.
fso.CopyFile CStr(archivos(p)), ruta, False
If fso.GetFile(ruta).Size <> fso.GetFile(CStr(archivos(p))).Size Then Err.Raise vbObjectError + 211, , "La copia tiene un tamano distinto al original."
copiados = copiados + 1
registro.WriteLine p & vbTab & p + 1 & vbTab & CStr(archivos(p)) & vbTab & ruta
Progreso "PDF recuperados", p, total
Next p
completo = True
GoTo Salida
Fallo:
errorTexto = "Error " & Err.Number & ": " & Err.Description
If p >= 1 And p <= total Then errorTexto = errorTexto & vbCrLf & "Pagina " & p & " (fila " & p + 1 & " de la hoja)."
Salida:
On Error Resume Next
If Not registro Is Nothing Then registro.Close
RestaurarEstado est
On Error GoTo 0
mEnCurso = False
If completo Then
Aviso copiados & " PDF copiados con su nombre en:" & vbCrLf & destino, vbInformation
ElseIf Len(errorTexto) > 0 Then
Aviso errorTexto & vbCrLf & "Copias completadas: " & copiados & vbCrLf & "Los originales no se han tocado.", vbExclamation
End If
End Sub
' Escapa los caracteres especiales de una expresion regular ("." "-" "(" ...).
Private Function EscaparRegExp(ByVal s As String) As String
Dim c As Variant
For Each c In Array("\", ".", "+", "*", "?", "^", "$", "(", ")", "[", "]", "{", "}", "|", "-")
s = Replace(s, CStr(c), "\" & CStr(c))
Next c
EscaparRegExp = s
End Function
Comprobar qué registros tienen archivo
Una lista (clientes, expedientes, pedidos) y una carpeta con documentos. La macro marca fila a fila si existe un archivo cuyo nombre contiene ese código, cuántos hay y cuál es el primero.
Antes
40 clientes en una hoja y una carpeta con 34 PDF de contratos y anexos.
Después
Tres columnas nuevas: Encontrado / No encontrado, número de coincidencias y nombre del archivo. Nueve filas sin contrato, localizadas al instante.
Qué problema te resuelve
Tienes una lista de clientes o expedientes y necesitas saber cuáles tienen ya su documentación. En lugar de buscar cada código en el explorador, la macro revisa los nombres de los archivos y te deja el resultado junto a cada fila de Excel.
Por qué te resultará práctica
- Ves qué falta de un vistazo: marca Encontrado o No encontrado. Puedes filtrar la hoja y centrarte en la documentación pendiente.
- Respeta tu forma de archivar: eliges la carpeta de búsqueda y decides si debe entrar también en sus subcarpetas. No necesitas juntar todos los documentos en una carpeta nueva.
- No se limita a PDF. Puedes buscar documentos de Word, otra extensión concreta o todos los tipos de archivo.
- Si encuentra varios nombres con el mismo código, indica cuántos hay y muestra el primero. Te ayuda a localizar posibles duplicados o varios documentos del mismo expediente para revisarlos.
- Los archivos se quedan donde están: no los mueve ni los renombra. Tú eliges en qué columnas de Excel se escriben los resultados.
Necesita: Excel.
Hoja Config: claves que lee esta macro
| Clave (columna A) | Valor (columna B) |
|---|---|
CarpetaBusqueda | Carpeta donde buscar |
HojaBusqueda | Hoja con los códigos |
ColumnaBusqueda | Columna con el texto a buscar |
FilaInicial | Primera fila con datos |
ColumnaResultado | Primera de las 3 columnas de salida |
ExtensionArchivo | pdf, docx… (vacío = todas) |
IncluirSubcarpetas | SI / NO |
Código · macro BuscarArchivos
Importa este módulo y modUtilidades (Alt+F11 → Archivo → Importar). Los comentarios >> ADAPTAR marcan los puntos pensados para cambiar.
Option Explicit
' =====================================================================
' modBuscarPDFs - Comprobar que registros tienen ya su archivo
'
' QUE HACE
' Recorre una columna de la hoja (codigos de cliente, expedientes,
' pedidos, DNI, referencias...) y, para cada valor, busca en una carpeta
' un archivo cuyo nombre CONTENGA ese texto. Escribe tres columnas:
' estado (Encontrado / No encontrado), numero de coincidencias y nombre
' del primer archivo encontrado.
'
' COMO USARLA
' 1. Importa modUtilidades.bas y este modulo en el editor de VBA
' (Alt+F11 > Archivo > Importar archivo). Guarda el libro como .xlsm.
' 2. Crea una hoja "Config" con dos columnas (A = clave, B = valor):
' CarpetaBusqueda C:\Documentos\Contratos (obligatoria)
' HojaBusqueda Registros (obligatoria)
' ColumnaBusqueda A columna con el texto a buscar
' FilaInicial 2 primera fila con datos
' ColumnaResultado H primera de las 3 columnas de salida
' (vacio = la siguiente a la ultima usada)
' ExtensionArchivo pdf vacio = cualquier extension
' IncluirSubcarpetas NO SI para recorrer subcarpetas
' 3. Ejecuta la macro BuscarArchivos (Alt+F8).
'
' POR QUE ES RAPIDA
' Lee la carpeta UNA sola vez y compara en memoria. Con 1.000 filas
' sobre una carpeta de red u OneDrive tarda menos de un segundo; la
' version habitual (un Dir por fila) tardaba minutos.
'
' PARA ADAPTARLA (busca los comentarios ">> ADAPTAR" en el codigo)
' - Comparar solo el principio del nombre en vez de "contiene".
' - Exigir coincidencia exacta del nombre sin extension.
' - Colorear las filas "No encontrado".
' Requiere: modUtilidades.
' =====================================================================
Public Sub BuscarArchivos()
Dim ws As Worksheet, fso As Object, carpeta As String, est As EstadoExcel
Dim colBusqueda As Long, colResultado As Long, filaIni As Long, filaFin As Long, extension As String
Dim valores As Variant, resultados() As Variant, nombres() As String, nombresReales() As String, totalArchivos As Long
Dim i As Long, j As Long, texto As String, coincidencias As Long, primero As String
On Error GoTo Fallo
carpeta = LeerConfig("CarpetaBusqueda")
Set ws = ThisWorkbook.Worksheets(LeerConfig("HojaBusqueda"))
colBusqueda = ColumnaANumero(LeerConfig("ColumnaBusqueda", False, "A"))
If Len(LeerConfig("ColumnaResultado", False)) > 0 Then
colResultado = ColumnaANumero(LeerConfig("ColumnaResultado", False))
Else
colResultado = ws.UsedRange.Column + ws.UsedRange.Columns.Count ' la siguiente a la ultima usada
End If
filaIni = ConfigLong("FilaInicial", 2)
extension = LCase$(Replace(LeerConfig("ExtensionArchivo", False, "pdf"), ".", ""))
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(carpeta) Then Err.Raise vbObjectError + 300, , "No existe la carpeta: " & carpeta
filaFin = UltimaFila(ws, colBusqueda)
If filaFin < filaIni Then
Aviso "No hay valores que buscar en la columna " & colBusqueda & ".", vbInformation
Exit Sub
End If
GuardarEstado est
Application.StatusBar = "Leyendo la carpeta..."
ReDim nombres(1 To 1024): ReDim nombresReales(1 To 1024)
ListarArchivos fso, fso.GetFolder(carpeta), extension, nombres, nombresReales, totalArchivos, ConfigBool("IncluirSubcarpetas", False)
valores = ws.Range(ws.Cells(filaIni, colBusqueda), ws.Cells(filaFin, colBusqueda)).Value
If Not IsArray(valores) Then valores = ws.Range(ws.Cells(filaIni, colBusqueda), ws.Cells(filaFin + 1, colBusqueda)).Value ' una sola fila: forzar array 2D
ReDim resultados(1 To filaFin - filaIni + 1, 1 To 3)
For i = 1 To UBound(resultados, 1)
If IsError(valores(i, 1)) Then texto = "" Else texto = LCase$(Trim$(CStr(valores(i, 1))))
If Len(texto) > 0 Then
coincidencias = 0: primero = ""
For j = 1 To totalArchivos
' >> ADAPTAR: criterio de coincidencia. Ahora: el nombre CONTIENE el texto.
' Solo al principio del nombre: If Left$(nombres(j), Len(texto)) = texto Then
' Nombre exacto sin extension: If fso.GetBaseName(nombres(j)) = texto Then
If InStr(1, nombres(j), texto, vbBinaryCompare) > 0 Then
coincidencias = coincidencias + 1
If Len(primero) = 0 Then primero = nombresReales(j)
End If
Next j
resultados(i, 1) = IIf(coincidencias > 0, "Encontrado", "No encontrado")
resultados(i, 2) = coincidencias
resultados(i, 3) = primero
End If
If i Mod 200 = 0 Then Progreso "Comprobando", i, UBound(resultados, 1)
Next i
ws.Cells(filaIni, colResultado).Resize(UBound(resultados, 1), 3).Value = resultados
' >> ADAPTAR: para resaltar las filas sin archivo, descomenta estas lineas:
' For i = 1 To UBound(resultados, 1)
' If resultados(i, 1) = "No encontrado" Then ws.Rows(filaIni + i - 1).Interior.Color = RGB(255, 199, 206)
' Next i
RestaurarEstado est
Aviso "Comprobadas " & UBound(resultados, 1) & " filas contra " & totalArchivos & " archivos." & vbCrLf & _
"Resultado en las columnas " & colResultado & " a " & colResultado + 2 & " (estado, coincidencias, primer archivo).", vbInformation
Exit Sub
Fallo:
RestaurarEstado est
Aviso "Error " & Err.Number & ": " & Err.Description, vbExclamation
End Sub
' Lista los archivos de la carpeta (y subcarpetas si se pide) con la extension
' indicada (vacia = todos). Guarda el nombre en minusculas para comparar sin
' distinguir mayusculas, y el nombre real para escribirlo en la hoja.
Private Sub ListarArchivos(ByVal fso As Object, ByVal carpeta As Object, ByVal extension As String, ByRef nombres() As String, _
ByRef nombresReales() As String, ByRef total As Long, ByVal recursivo As Boolean)
Dim f As Object, sub1 As Object
For Each f In carpeta.Files
If Len(extension) = 0 Or LCase$(fso.GetExtensionName(f.Name)) = extension Then
total = total + 1
If total > UBound(nombres) Then
ReDim Preserve nombres(1 To UBound(nombres) * 2)
ReDim Preserve nombresReales(1 To UBound(nombresReales) * 2)
End If
nombres(total) = LCase$(f.Name)
nombresReales(total) = f.Name
End If
Next f
If recursivo Then
For Each sub1 In carpeta.SubFolders
ListarArchivos fso, sub1, extension, nombres, nombresReales, total, True
Next sub1
End If
End Sub
Desglosar un resumen en sus líneas
Una hoja Resumen con el importe total de cada pedido, artículo o proyecto, y una hoja Detalle con las líneas que lo componen, en cualquier orden. La macro sustituye cada fila resumen por sus líneas, en su sitio, con los campos de detalle que elijas.
Antes
20 pedidos con su importe total; 90 líneas de detalle desordenadas en otra hoja; una tabla de códigos.
Después
26 pedidos desglosados en 81 filas nuevas (en verde), con el componente traducido, cantidad e importe; el orden de la hoja intacto; y lo que no cuadra anotado en Desglose_Log con el motivo.
Qué problema te resuelve
En una hoja tienes el total de cada pedido y en otra, las líneas que lo componen. Unir ambas a mano supone buscar, copiar, insertar filas y comprobar sumas. La macro coloca el detalle donde corresponde, aunque venga desordenado.
Por qué te resultará práctica
- Te ahorra ir de una hoja a otra copiando líneas: sustituye cada resumen por su detalle en el mismo lugar, respetando el orden de trabajo.
- Comprueba que las cuentas encajan: compara la suma del detalle con el total y permite fijar un margen para pequeñas diferencias de redondeo.
- Si un código aparece en varios pedidos, puedes indicar qué columna distingue sus grupos. Así puede asociarlos por código e importe sin asignar dos grupos a la misma fila de resumen.
- Se adapta a tus columnas: eliges qué datos llevar y dónde colocarlos. También puede cambiar códigos por descripciones usando tu tabla de equivalencias.
- Lo que no encaja queda anotado en una hoja de registro para que lo revises. Como modifica la hoja de trabajo, empieza siempre con una copia del libro.
Necesita: Excel. Trabaja sobre la hoja del propio libro: guarda una copia antes.
Hoja Config: claves que lee esta macro
| Clave (columna A) | Valor (columna B) |
|---|---|
HojaResumen / HojaDetalle | Nombres de las dos hojas |
ClaveResumen / ClaveDetalle | Columna de la clave en cada hoja |
ImporteResumen / ImporteDetalle | Columna del importe en cada hoja |
SubgrupoDetalle | Opcional: columna que separa subgrupos |
Tolerancia | Diferencia admitida (0,2) |
CamposDetalle | F>K,G>R,C>P! — qué columna de detalle va a cuál de resumen; ! = traducir |
ColumnaEtiqueta / TextoEtiqueta | Opcional: etiqueta por grupo, {n} = subgrupo |
Código · macro DesglosarFilasPorClave
Importa este módulo y modUtilidades (Alt+F11 → Archivo → Importar). Los comentarios >> ADAPTAR marcan los puntos pensados para cambiar.
Option Explicit
' =====================================================================
' modDesgloseFilasPorClave - Sustituir cada fila "resumen" por sus
' lineas de "detalle", emparejadas por una clave y un importe.
'
' QUE HACE
' Caso tipico: una hoja RESUMEN con una fila por articulo, pedido,
' albaran, proyecto... (clave + importe total) y una hoja DETALLE con
' varias lineas por esa misma clave (componentes, partidas, conceptos),
' en cualquier orden. La macro localiza en RESUMEN la fila cuyo importe
' coincide con la suma de sus lineas de DETALLE (con tolerancia),
' inserta debajo una copia por cada linea con los campos de detalle que
' indiques, y elimina la fila resumen original. Las filas nuevas quedan
' en verde, la hoja conserva el orden y lo que no cuadra NO se toca:
' queda anotado en la hoja Desglose_Log con el motivo.
'
' COMO USARLA
' 1. Importa modUtilidades.bas y este modulo (Alt+F11 > Importar).
' 2. Rellena la hoja "Config" con las claves de abajo.
' 3. Ejecuta DesglosarFilasPorClave (Alt+F8). Trabaja sobre la hoja
' resumen del propio libro: guarda una copia antes o usa Deshacer.
'
' PARA ADAPTARLA (busca ">> ADAPTAR")
' - Color de las filas nuevas (COLOR_FILA_NUEVA).
' - Emparejar sin comprobar el importe (solo por clave).
' - Conservar la fila resumen en vez de eliminarla.
'
' Configuracion (hoja "Config", columna A clave / columna B valor):
' HojaResumen Nombre de la hoja resumen (ej. Resumen)
' HojaDetalle Nombre de la hoja detalle (ej. Detalle)
' ClaveResumen Columna de la clave en resumen (ej. B)
' ClaveDetalle Columna de la clave en detalle (ej. B)
' SubgrupoDetalle Columna que separa subgrupos dentro de una
' misma clave (opcional, ej. A). Cada subgrupo se
' empareja con una fila resumen distinta.
' ImporteResumen Columna del importe en resumen (ej. K)
' ImporteDetalle Columna del importe en detalle (ej. F)
' Tolerancia Diferencia admitida entre importe y suma (0,2)
' CamposDetalle Que columnas de detalle van a que columnas de
' resumen, separadas por coma: "F>K,G>R,C>P"
' (detalle>resumen). Si una pareja termina en "!"
' (ej. "C>P!") el valor se traduce con la hoja
' Tabla (columna A codigo, columna B texto).
' ColumnaEtiqueta Columna de resumen donde escribir la etiqueta
' del grupo (opcional, ej. Q)
' TextoEtiqueta Texto de la etiqueta; {n} = numero de subgrupo
' (ej. "Linea {n} del desglose")
' Requiere: modUtilidades.
' =====================================================================
' >> ADAPTAR: color de las filas insertadas (verde claro de Excel). 0 = sin color.
Private Const COLOR_FILA_NUEVA As Long = 13561798 ' RGB(198,239,206)
Private Type Pareja
ColDetalle As Long
ColResumen As Long
Traducir As Boolean
End Type
Public Sub DesglosarFilasPorClave()
Dim wsRes As Worksheet, wsDet As Worksheet, wsLog As Worksheet, est As EstadoExcel
Dim cClaveRes As Long, cClaveDet As Long, cSub As Long, cImpRes As Long, cImpDet As Long, cEtiq As Long
Dim tolerancia As Double, textoEtiqueta As String, parejas() As Pareja, nParejas As Long, tabla As Object
Dim ultRes As Long, ultDet As Long, maxColDet As Long, maxColRes As Long
Dim det As Variant, res As Variant, i As Long, j As Long, n As Long, r As Long
Dim grupos As Object, ordenGrupos As Collection, numSub As Object, subDict As Object
Dim indiceRes As Object, filaTomada As Object, plan As Object, filasPlan() As Long
Dim cg As Variant, partes() As String, k As String, sub1 As String, suma As Double
Dim filaCoincidente As Long, fila As Variant, detFilas As Collection, logFilas As Collection
Dim desglosados As Long, noEncontrados As Long, filasNuevas As Long, v As Variant, msg As String
On Error GoTo Fallo
' ---- Configuracion ----
Set wsRes = ThisWorkbook.Worksheets(LeerConfig("HojaResumen"))
Set wsDet = ThisWorkbook.Worksheets(LeerConfig("HojaDetalle"))
cClaveRes = ColumnaANumero(LeerConfig("ClaveResumen"))
cClaveDet = ColumnaANumero(LeerConfig("ClaveDetalle"))
If Len(LeerConfig("SubgrupoDetalle", False)) > 0 Then cSub = ColumnaANumero(LeerConfig("SubgrupoDetalle", False))
cImpRes = ColumnaANumero(LeerConfig("ImporteResumen"))
cImpDet = ColumnaANumero(LeerConfig("ImporteDetalle"))
If Len(LeerConfig("ColumnaEtiqueta", False)) > 0 Then cEtiq = ColumnaANumero(LeerConfig("ColumnaEtiqueta", False))
textoEtiqueta = LeerConfig("TextoEtiqueta", False, "Linea {n} del desglose")
tolerancia = Val(Replace(LeerConfig("Tolerancia", False, "0.2"), ",", "."))
If tolerancia < 0 Then tolerancia = 0
nParejas = LeerParejas(LeerConfig("CamposDetalle"), parejas)
For j = 1 To nParejas
If parejas(j).Traducir And tabla Is Nothing Then Set tabla = CargarTabla()
Next j
ultRes = UltimaFila(wsRes, cClaveRes)
ultDet = UltimaFila(wsDet, cClaveDet)
If ultRes < 2 Or ultDet < 2 Then Err.Raise vbObjectError + 400, , "No hay datos en resumen o detalle."
maxColDet = Maximo(cClaveDet, cSub, cImpDet)
maxColRes = Maximo(cClaveRes, cImpRes, 1)
For j = 1 To nParejas
If parejas(j).ColDetalle > maxColDet Then maxColDet = parejas(j).ColDetalle
Next j
det = wsDet.Range(wsDet.Cells(2, 1), wsDet.Cells(ultDet, maxColDet)).Value
res = wsRes.Range(wsRes.Cells(2, 1), wsRes.Cells(ultRes, maxColRes)).Value
' ---- 1) Agrupar detalle por clave (+ subgrupo), en orden de aparicion ----
Set grupos = CreateObject("Scripting.Dictionary"): Set ordenGrupos = New Collection
Set numSub = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(det, 1)
k = Clave(det(i, cClaveDet))
If Len(k) > 0 Then
If cSub > 0 Then sub1 = Clave(det(i, cSub)) Else sub1 = "1"
If Len(sub1) > 0 Then
cg = k & vbNullChar & sub1
If Not grupos.Exists(cg) Then
grupos.Add cg, New Collection
ordenGrupos.Add cg
If Not numSub.Exists(k) Then numSub.Add k, CreateObject("Scripting.Dictionary")
Set subDict = numSub(k)
subDict.Add sub1, subDict.Count + 1
End If
grupos(cg).Add i
End If
End If
Next i
' ---- 2) Indice del resumen por clave ----
Set indiceRes = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(res, 1)
k = Clave(res(i, cClaveRes))
If Len(k) > 0 Then
If Not indiceRes.Exists(k) Then indiceRes.Add k, New Collection
indiceRes(k).Add i + 1
End If
Next i
' ---- 3) Emparejar cada grupo con una fila resumen libre de igual clave e importe ----
Set filaTomada = CreateObject("Scripting.Dictionary"): Set plan = CreateObject("Scripting.Dictionary")
Set logFilas = New Collection
For Each cg In ordenGrupos
partes = Split(cg, vbNullChar): k = partes(0): sub1 = partes(1)
suma = 0
For Each fila In grupos(cg)
suma = suma + Numero(det(fila, cImpDet))
Next fila
filaCoincidente = 0
If indiceRes.Exists(k) Then
For Each fila In indiceRes(k)
If Not filaTomada.Exists(fila) Then
' >> ADAPTAR: criterio de emparejamiento. Ahora: misma clave e importe igual a la
' suma de las lineas (+/- Tolerancia). Para emparejar solo por clave (la primera
' fila libre con esa clave) sustituye la condicion por: If True Then
If Abs(Numero(res(fila - 1, cImpRes)) - suma) <= tolerancia Then filaCoincidente = fila: Exit For
End If
Next fila
End If
If filaCoincidente > 0 Then
filaTomada.Add filaCoincidente, True
plan.Add filaCoincidente, Array(cg, numSub(k)(sub1))
desglosados = desglosados + 1
Else
noEncontrados = noEncontrados + 1
logFilas.Add Array(k, sub1, suma, "Sin fila resumen con esa clave e importe (+/- " & tolerancia & ")")
End If
Next cg
If plan.Count = 0 Then
EscribirLog wsLog, logFilas, 0, noEncontrados, 0
Aviso "Ninguna coincidencia. Revisa la hoja Desglose_Log.", vbExclamation
Exit Sub
End If
' ---- 4) Ejecutar de abajo arriba para no desplazar filas pendientes ----
GuardarEstado est
ReDim filasPlan(1 To plan.Count): i = 0
For Each fila In plan.Keys
i = i + 1: filasPlan(i) = fila
Next fila
OrdenarDescendente filasPlan
For i = 1 To UBound(filasPlan)
r = filasPlan(i)
Set detFilas = grupos(plan(r)(0))
n = detFilas.Count
wsRes.Rows(r + 1).Resize(n).Insert Shift:=xlDown
wsRes.Rows(r).Copy wsRes.Rows(r + 1).Resize(n)
For Each fila In detFilas
r = r + 1
For j = 1 To nParejas
v = det(fila, parejas(j).ColDetalle)
If IsError(v) Then v = ""
If parejas(j).Traducir Then v = Traducir(tabla, v)
wsRes.Cells(r, parejas(j).ColResumen).Value = v
Next j
If cEtiq > 0 Then wsRes.Cells(r, cEtiq).Value = Replace(textoEtiqueta, "{n}", CStr(plan(filasPlan(i))(1)))
wsRes.Rows(r).Interior.Color = COLOR_FILA_NUEVA
filasNuevas = filasNuevas + 1
Next fila
' >> ADAPTAR: para conservar la fila resumen como cabecera del grupo (en vez de
' eliminarla), comenta la linea siguiente.
wsRes.Rows(filasPlan(i)).Delete
Progreso "Desglosando", i, UBound(filasPlan)
Next i
Application.CutCopyMode = False
RestaurarEstado est
EscribirLog wsLog, logFilas, desglosados, noEncontrados, filasNuevas
msg = "Desglose completado." & vbCrLf & "Filas resumen desglosadas: " & desglosados & vbCrLf & _
"Filas nuevas (verdes): " & filasNuevas & vbCrLf & "Grupos sin coincidencia: " & noEncontrados
If noEncontrados > 0 Then msg = msg & vbCrLf & "Detalle en la hoja Desglose_Log."
Aviso msg, vbInformation
Exit Sub
Fallo:
Application.CutCopyMode = False
RestaurarEstado est
Aviso "Error " & Err.Number & ": " & Err.Description & vbCrLf & _
"La hoja puede haber quedado a medias: cierra sin guardar o usa Deshacer.", vbExclamation
End Sub
' "F>K,G>R,C>P!" -> parejas detalle>resumen; "!" = traducir con la hoja Tabla
Private Function LeerParejas(ByVal texto As String, ByRef parejas() As Pareja) As Long
Dim trozos() As String, i As Long, lados() As String, n As Long
trozos = Split(texto, ",")
ReDim parejas(1 To UBound(trozos) + 1)
For i = LBound(trozos) To UBound(trozos)
lados = Split(Trim$(trozos(i)), ">")
If UBound(lados) <> 1 Then Err.Raise vbObjectError + 401, , "CamposDetalle: pareja no valida '" & trozos(i) & "'. Formato: F>K"
n = n + 1
parejas(n).ColDetalle = ColumnaANumero(Trim$(lados(0)))
parejas(n).Traducir = (Right$(Trim$(lados(1)), 1) = "!")
parejas(n).ColResumen = ColumnaANumero(Replace(Trim$(lados(1)), "!", ""))
Next i
If n = 0 Then Err.Raise vbObjectError + 402, , "CamposDetalle esta vacio."
LeerParejas = n
End Function
' Hoja "Tabla": columna A codigo, columna B texto. Varias columnas de
' codigo se admiten concatenadas (ej. "01" & "02" en A).
Private Function CargarTabla() As Object
Dim ws As Worksheet, d As Object, datos As Variant, i As Long, ult As Long
Set d = CreateObject("Scripting.Dictionary"): d.CompareMode = vbTextCompare
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(LeerConfig("HojaTabla", False, "Tabla"))
On Error GoTo 0
If ws Is Nothing Then Err.Raise vbObjectError + 403, , "Falta la hoja Tabla (codigo en A, texto en B) para traducir valores."
ult = UltimaFila(ws, 1)
If ult >= 1 Then
datos = ws.Range("A1:B" & ult).Value
For i = 1 To ult
If Not IsError(datos(i, 1)) Then
If Len(Trim$(CStr(datos(i, 1) & ""))) > 0 And Not d.Exists(Trim$(CStr(datos(i, 1)))) Then d.Add Trim$(CStr(datos(i, 1))), datos(i, 2)
End If
Next i
End If
Set CargarTabla = d
End Function
Private Function Traducir(ByVal tabla As Object, ByVal v As Variant) As Variant
Dim k As String
If IsError(v) Then v = ""
k = Trim$(CStr(v & ""))
If tabla.Exists(k) Then Traducir = tabla(k) Else Traducir = "NO DEFINIDO (" & k & ")"
End Function
Private Function Clave(ByVal v As Variant) As String
If IsError(v) Then v = ""
Clave = Trim$(CStr(v & ""))
If IsNumeric(Clave) And Len(Clave) > 0 Then Clave = CStr(CDbl(Clave)) ' "007" y 7 son la misma clave
End Function
Private Function Numero(ByVal v As Variant) As Double
Dim s As String
If IsError(v) Then v = ""
If IsNumeric(v) And VarType(v) <> vbString Then
Numero = CDbl(v)
Else
s = Replace(Trim$(CStr(v & "")), ",", ".")
If IsNumeric(s) Then Numero = Val(s)
End If
End Function
Private Function Maximo(ByVal a As Long, ByVal b As Long, ByVal c As Long) As Long
Maximo = a
If b > Maximo Then Maximo = b
If c > Maximo Then Maximo = c
End Function
Private Sub OrdenarDescendente(ByRef a() As Long)
Dim i As Long, j As Long, t As Long
For i = LBound(a) To UBound(a) - 1
For j = i + 1 To UBound(a)
If a(j) > a(i) Then t = a(i): a(i) = a(j): a(j) = t
Next j
Next i
End Sub
Private Sub EscribirLog(ByRef wsLog As Worksheet, ByVal filas As Collection, ByVal desglosados As Long, _
ByVal noEncontrados As Long, ByVal filasNuevas As Long)
Dim i As Long, f As Variant
On Error Resume Next
Set wsLog = ThisWorkbook.Worksheets("Desglose_Log")
On Error GoTo 0
If wsLog Is Nothing Then
Set wsLog = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
wsLog.Name = "Desglose_Log"
End If
wsLog.Cells.Clear
wsLog.Range("A1:D1").Value = Array("Clave", "Subgrupo", "Suma detalle", "Motivo")
wsLog.Range("A1:D1").Font.Bold = True
i = 1
For Each f In filas
i = i + 1
wsLog.Cells(i, 1).Resize(1, 4).Value = f
Next f
i = i + 2
wsLog.Cells(i, 1).Value = "Ejecutado": wsLog.Cells(i, 2).Value = Format$(Now, "yyyy-mm-dd hh:nn")
wsLog.Cells(i + 1, 1).Value = "Filas resumen desglosadas": wsLog.Cells(i + 1, 2).Value = desglosados
wsLog.Cells(i + 2, 1).Value = "Filas nuevas": wsLog.Cells(i + 2, 2).Value = filasNuevas
wsLog.Cells(i + 3, 1).Value = "Grupos sin coincidencia": wsLog.Cells(i + 3, 2).Value = noEncontrados
wsLog.Columns("A:D").AutoFit
End Sub
Convertir una hoja a otra estructura
Te llega un fichero con unas columnas y códigos (un ERP, un proveedor, un portal) y tienes que entregarlo con otras. En vez de tocar código, describes la conversión en una hoja Mapeo: una fila por columna de salida.
Antes
200 productos con códigos de familia y material, tres tablas maestras y una hoja Mapeo de 9 filas.
Después
Un libro nuevo con las cabeceras del mapeo, códigos traducidos, ventas cruzadas desde otra hoja y S/N normalizado. Lo que no está en las tablas se señala (NO DEFINIDO o el texto que elijas), nunca se inventa.
Qué problema te resuelve
Te llega un Excel de un proveedor o de tu programa de gestión, pero necesitas entregarlo con otras columnas, nombres y códigos. Esta macro evita que tengas que reorganizar el mismo tipo de fichero a mano cada vez que llega uno nuevo.
Por qué te resultará práctica
- Defines una vez cómo debe quedar la salida en la hoja Mapeo: qué columnas quieres, cómo se llaman y de dónde sale cada dato. Después puedes reutilizar esas reglas.
- Hace más que cambiar columnas de sitio: puede traducir códigos con tus tablas, traer datos de otras hojas, unificar valores de sí/no y añadir textos fijos.
- Guarda automáticamente el resultado en un libro nuevo, junto al libro de la macro, con un nombre que incluye fecha y hora. El fichero de partida se conserva.
- Puedes trabajar desde la carpeta que ya utilizas para ese proceso y mantener allí las salidas. Si necesitas otro nombre o destino, el código señala el punto donde adaptarlo.
- Cuando cambia el formato que te piden, ajustas la hoja Mapeo. Si falta una equivalencia, la salida lo señala con el texto que elijas, para que sepas qué revisar antes de entregarla.
Necesita: Excel. El libro debe estar guardado: la salida se crea en su misma carpeta.
Hoja Config: claves que lee esta macro
| Clave (columna A) | Valor (columna B) |
|---|---|
HojaBase | Hoja cuyas filas producen la salida |
HojaMapeo | Hoja con las reglas (Mapeo) |
NombreSalida | Nombre de la hoja de salida |
CopiarMaestros | SI para llevar las tablas al libro nuevo |
Hoja Mapeo (una fila por columna de salida)
| Columna | Qué contiene |
|---|---|
ColumnaSalida | Columna de la salida (C, AA…) |
Cabecera | Texto de cabecera |
Operacion | COPIAR | BUSCAR | CRUZAR | SI_NO | FIJO |
Origen | Columna(s) de la hoja base, o el texto fijo |
Hoja | Tabla maestra o hoja a cruzar |
ColumnasClave | Columna(s) clave en esa hoja (A|B) |
ColumnaValor | Columna con el valor a traer |
SiNoEncontrado | Texto si la clave no existe |
Código · macro ReestructurarConMapeo
Importa este módulo y modUtilidades (Alt+F11 → Archivo → Importar). Los comentarios >> ADAPTAR marcan los puntos pensados para cambiar.
Option Explicit
' =====================================================================
' modReestructurarConMapeo - Convertir una hoja a otra estructura de
' columnas siguiendo una hoja de MAPEO, con busquedas en tablas maestras
' y cruces con otras hojas. Sin tocar el codigo: cambiar el mapeo cambia
' la conversion.
'
' QUE HACE
' Caso tipico: te llega un fichero con una estructura (un ERP, un
' proveedor, un portal) y tienes que entregarlo con otra (una plantilla
' oficial, otro sistema), traduciendo codigos a descripciones por medio
' de tablas y completando columnas desde otras hojas. La salida se
' escribe en un libro NUEVO (.xlsx con fecha y hora) junto al original.
'
' COMO USARLA
' 1. Importa modUtilidades.bas y este modulo (Alt+F11 > Importar).
' Guarda el libro como .xlsm (la salida se crea en su misma carpeta).
' 2. Crea la hoja "Mapeo" (una fila por columna de salida, ver abajo)
' y la hoja "Config" con HojaBase.
' 3. Ejecuta ReestructurarConMapeo (Alt+F8).
'
' PARA ADAPTARLA (busca ">> ADAPTAR")
' - Anadir una operacion nueva (p. ej. FECHA, MAYUSCULAS, CONCATENAR).
' - Escribir la salida en el mismo libro en vez de en uno nuevo.
' - Cambiar el nombre o la carpeta del archivo de salida.
'
' Hoja "Config":
' HojaBase Hoja cuyas filas producen la salida (una fila por fila)
' HojaMapeo Nombre de la hoja de mapeo (Mapeo)
' NombreSalida Nombre de la hoja de salida en el libro nuevo (Salida)
' CopiarMaestros SI para copiar las hojas maestras al libro de salida
'
' Hoja "Mapeo" (una fila por columna de salida; la fila 1 es cabecera):
' A ColumnaSalida Columna de la hoja de salida (ej. C o AA)
' B Cabecera Texto de cabecera en la salida
' C Operacion COPIAR | BUSCAR | CRUZAR | SI_NO | FIJO
' D Origen COPIAR/SI_NO/BUSCAR: columna(s) de HojaBase ("C" o "C|D")
' CRUZAR: columna(s) de HojaBase con la clave ("A")
' FIJO: el texto fijo
' E Hoja BUSCAR: hoja maestra. CRUZAR: hoja a cruzar
' F ColumnasClave BUSCAR/CRUZAR: columna(s) clave en esa hoja ("A|B")
' G ColumnaValor BUSCAR/CRUZAR: columna con el valor a traer
' H SiNoEncontrado Texto si la clave no existe (vacio = "NO DEFINIDO (clave)")
'
' Operaciones:
' COPIAR copia el valor de la columna de origen (recortado)
' BUSCAR forma la clave con las columnas de Origen y la busca en la
' hoja maestra (ColumnasClave) devolviendo ColumnaValor
' CRUZAR igual que BUSCAR pero pensado para hojas de datos: trae la
' primera coincidencia (equivale a un BUSCARV con varias claves)
' SI_NO S/N (o SI/NO, Y/N, 1/0, VERDADERO/FALSO) -> "Si" / "No"
' FIJO escribe el texto de Origen en todas las filas
' Requiere: modUtilidades.
' =====================================================================
Private Type Regla
ColSalida As Long
Cabecera As String
Operacion As String
Origen As String
ColsOrigen() As Long
Hoja As String
Dict As Object
SiNoEncontrado As String
End Type
Public Sub ReestructurarConMapeo()
Dim wsBase As Worksheet, wsMapeo As Worksheet, wbOut As Workbook, wsOut As Worksheet, est As EstadoExcel
Dim reglas() As Regla, nReglas As Long, i As Long, j As Long, ultBase As Long, maxColBase As Long, maxColOut As Long
Dim base As Variant, salida() As Variant, k As String, v As Variant, ruta As String, t As Double, cabeceras() As Variant
Dim cachesMaestros As Object, claveCache As String
On Error GoTo Fallo
t = CDbl(Timer)
If Len(ThisWorkbook.Path) = 0 Then Err.Raise vbObjectError + 503, , "Guarda el libro antes de reestructurar."
Set wsBase = Hoja(LeerConfig("HojaBase"))
Set wsMapeo = Hoja(LeerConfig("HojaMapeo", False, "Mapeo"))
GuardarEstado est
Application.StatusBar = "Leyendo el mapeo..."
Set cachesMaestros = CreateObject("Scripting.Dictionary")
nReglas = LeerReglas(wsMapeo, reglas, cachesMaestros)
ultBase = UltimaFila(wsBase, 1)
If ultBase < 2 Then Err.Raise vbObjectError + 502, , "La hoja base no tiene filas de datos."
For i = 1 To nReglas
For j = LBound(reglas(i).ColsOrigen) To UBound(reglas(i).ColsOrigen)
If reglas(i).ColsOrigen(j) > maxColBase Then maxColBase = reglas(i).ColsOrigen(j)
Next j
If reglas(i).ColSalida > maxColOut Then maxColOut = reglas(i).ColSalida
Next i
If maxColBase < 2 Then maxColBase = 2 ' asi .Value devuelve siempre un array 2D
base = wsBase.Range(wsBase.Cells(2, 1), wsBase.Cells(ultBase, maxColBase)).Value
Application.StatusBar = "Construyendo la salida..."
ReDim salida(1 To UBound(base, 1), 1 To maxColOut)
ReDim cabeceras(1 To 1, 1 To maxColOut)
For i = 1 To nReglas
cabeceras(1, reglas(i).ColSalida) = reglas(i).Cabecera
Next i
For i = 1 To UBound(base, 1)
For j = 1 To nReglas
Select Case reglas(j).Operacion
Case "COPIAR"
salida(i, reglas(j).ColSalida) = Valor(base(i, reglas(j).ColsOrigen(0)))
Case "SI_NO"
salida(i, reglas(j).ColSalida) = SiNo(base(i, reglas(j).ColsOrigen(0)))
Case "FIJO"
salida(i, reglas(j).ColSalida) = reglas(j).Origen
' >> ADAPTAR: para una operacion nueva anade un Case aqui y otro en LeerReglas
' (para validar sus columnas). Ejemplos:
' Case "MAYUSCULAS": salida(i, reglas(j).ColSalida) = UCase$(Limpiar(base(i, reglas(j).ColsOrigen(0))))
' Case "CONCATENAR": salida(i, reglas(j).ColSalida) = Replace(ClaveDe(base, i, reglas(j).ColsOrigen), "|", " ")
Case "BUSCAR", "CRUZAR"
k = ClaveDe(base, i, reglas(j).ColsOrigen)
If Len(Replace(k, "|", "")) = 0 Then
salida(i, reglas(j).ColSalida) = ""
ElseIf reglas(j).Dict.Exists(k) Then
salida(i, reglas(j).ColSalida) = reglas(j).Dict(k)
ElseIf Len(reglas(j).SiNoEncontrado) > 0 Then
salida(i, reglas(j).ColSalida) = reglas(j).SiNoEncontrado
Else
salida(i, reglas(j).ColSalida) = "NO DEFINIDO (" & Replace(k, "|", "-") & ")"
End If
End Select
Next j
If i Mod 500 = 0 Then Progreso "Filas", i, UBound(base, 1)
Next i
Application.StatusBar = "Escribiendo el libro de salida..."
Set wbOut = Workbooks.Add(xlWBATWorksheet)
Set wsOut = wbOut.Worksheets(1)
wsOut.Name = LeerConfig("NombreSalida", False, "Salida")
wsOut.Range("A1").Resize(1, maxColOut).Value = cabeceras
wsOut.Range("A1").Resize(1, maxColOut).Font.Bold = True
wsOut.Range("A2").Resize(UBound(salida, 1), maxColOut).Value = salida
wsOut.Columns(1).Resize(, maxColOut).AutoFit
If ConfigBool("CopiarMaestros", False) Then CopiarMaestros wbOut, reglas, nReglas
' >> ADAPTAR: nombre y carpeta del archivo de salida. Para escribir en el propio libro
' (sin crear uno nuevo) sustituye Workbooks.Add por ThisWorkbook.Worksheets.Add y quita el SaveAs.
ruta = ThisWorkbook.Path & "\" & wsOut.Name & "_" & Format$(Now, "yyyymmdd_hhmmss") & ".xlsx"
Application.DisplayAlerts = False
wbOut.SaveAs Filename:=ruta, FileFormat:=51
Application.DisplayAlerts = True
wsOut.Activate
wsOut.Range("A1").Select
RestaurarEstado est
Aviso UBound(salida, 1) & " filas reestructuradas en " & Format$(SegundosDesde(t), "0.0") & " s." & vbCrLf & "Archivo: " & ruta, vbInformation
Exit Sub
Fallo:
RestaurarEstado est
Aviso "Error " & Err.Number & ": " & Err.Description, vbCritical
End Sub
' ---------- Mapeo ----------
Private Function LeerReglas(ByVal wsMapeo As Worksheet, ByRef reglas() As Regla, ByVal caches As Object) As Long
Dim ult As Long, datos As Variant, i As Long, n As Long, op As String, claveCache As String
ult = UltimaFila(wsMapeo, 1)
If ult < 2 Then Err.Raise vbObjectError + 504, , "La hoja Mapeo esta vacia."
datos = wsMapeo.Range("A2:H" & ult).Value
ReDim reglas(1 To UBound(datos, 1))
For i = 1 To UBound(datos, 1)
If Len(Trim$(Limpiar(datos(i, 1)))) > 0 Then
n = n + 1
With reglas(n)
.ColSalida = ColumnaANumero(Limpiar(datos(i, 1)))
.Cabecera = Trim$(Limpiar(datos(i, 2)))
.Operacion = UCase$(Trim$(Limpiar(datos(i, 3))))
.Origen = Trim$(Limpiar(datos(i, 4)))
.Hoja = Trim$(Limpiar(datos(i, 5)))
.SiNoEncontrado = Trim$(Limpiar(datos(i, 8)))
Select Case .Operacion
Case "COPIAR", "SI_NO"
.ColsOrigen = Columnas(.Origen, "Mapeo fila " & i + 1)
Case "FIJO"
ReDim .ColsOrigen(0 To 0)
Case "BUSCAR", "CRUZAR"
.ColsOrigen = Columnas(.Origen, "Mapeo fila " & i + 1)
If Len(.Hoja) = 0 Or Len(Trim$(Limpiar(datos(i, 6)))) = 0 Or Len(Trim$(Limpiar(datos(i, 7)))) = 0 Then
Err.Raise vbObjectError + 505, , "Mapeo fila " & i + 1 & ": BUSCAR/CRUZAR necesita Hoja, ColumnasClave y ColumnaValor."
End If
' Un diccionario por (hoja, claves, valor); se reutiliza entre reglas.
claveCache = .Hoja & "|" & UCase$(Limpiar(datos(i, 6))) & "|" & UCase$(Limpiar(datos(i, 7)))
If Not caches.Exists(claveCache) Then
caches.Add claveCache, DiccionarioDe(Hoja(.Hoja), Limpiar(datos(i, 6)), Limpiar(datos(i, 7)))
End If
Set .Dict = caches(claveCache)
Case Else
Err.Raise vbObjectError + 506, , "Mapeo fila " & i + 1 & ": operacion desconocida '" & .Operacion & "'."
End Select
End With
End If
Next i
If n = 0 Then Err.Raise vbObjectError + 504, , "La hoja Mapeo no tiene reglas."
ReDim Preserve reglas(1 To n)
LeerReglas = n
End Function
Private Function Columnas(ByVal texto As String, ByVal donde As String) As Long()
Dim trozos() As String, r() As Long, i As Long
If Len(Trim$(texto)) = 0 Then Err.Raise vbObjectError + 507, , donde & ": falta la columna de origen."
trozos = Split(texto, "|")
ReDim r(0 To UBound(trozos))
For i = 0 To UBound(trozos)
r(i) = ColumnaANumero(Trim$(trozos(i)))
Next i
Columnas = r
End Function
' Diccionario clave compuesta ("A|B") -> valor. Primera aparicion gana,
' comparacion sin distinguir mayusculas, claves recortadas; la fila 1 se
' incluye por si la tabla no tiene cabecera.
Private Function DiccionarioDe(ByVal ws As Worksheet, ByVal columnasClave As String, ByVal colValor As String) As Object
Dim d As Object, cols() As Long, cV As Long, maxCol As Long, ult As Long, datos As Variant, i As Long, j As Long, k As String
Set d = CreateObject("Scripting.Dictionary"): d.CompareMode = vbTextCompare
cols = Columnas(columnasClave, "Maestro " & ws.Name)
cV = ColumnaANumero(colValor): maxCol = cV
For j = 0 To UBound(cols)
If cols(j) > maxCol Then maxCol = cols(j)
Next j
ult = UltimaFila(ws, cols(0))
If ult >= 1 Then
datos = ws.Range(ws.Cells(1, 1), ws.Cells(ult, maxCol)).Value
For i = 1 To ult
k = ClaveDe(datos, i, cols)
If Len(Replace(k, "|", "")) > 0 And Not d.Exists(k) Then d.Add k, Valor(datos(i, cV))
Next i
End If
Set DiccionarioDe = d
End Function
Private Function ClaveDe(ByRef datos As Variant, ByVal fila As Long, ByRef cols() As Long) As String
Dim j As Long, k As String
For j = 0 To UBound(cols)
If j > 0 Then k = k & "|"
k = k & Limpiar(datos(fila, cols(j)))
Next j
ClaveDe = k
End Function
' ---------- Maestros al libro de salida ----------
Private Sub CopiarMaestros(ByVal wbOut As Workbook, ByRef reglas() As Regla, ByVal n As Long)
Dim hechas As Object, i As Long
Set hechas = CreateObject("Scripting.Dictionary"): hechas.CompareMode = vbTextCompare
For i = 1 To n
If (reglas(i).Operacion = "BUSCAR" Or reglas(i).Operacion = "CRUZAR") And Not hechas.Exists(reglas(i).Hoja) Then
hechas.Add reglas(i).Hoja, True
Hoja(reglas(i).Hoja).Copy After:=wbOut.Worksheets(wbOut.Worksheets.Count)
End If
Next i
End Sub
' ---------- Auxiliares ----------
Private Function Hoja(ByVal nombre As String) As Worksheet
On Error Resume Next
Set Hoja = ThisWorkbook.Worksheets(nombre)
On Error GoTo 0
If Hoja Is Nothing Then Err.Raise vbObjectError + 500, , "Falta la hoja '" & nombre & "'."
End Function
Private Function SiNo(ByVal valor As Variant) As String
Select Case UCase$(Trim$(CStr(valor & "")))
Case "S", "SI", "SÍ", "Y", "YES", "1", "TRUE", "VERDADERO", "X": SiNo = "Sí"
Case "N", "NO", "0", "FALSE", "FALSO": SiNo = "No"
Case Else: SiNo = ""
End Select
End Function
' Conserva numeros y fechas como tales; recorta los textos; los errores quedan vacios.
Private Function Valor(ByVal v As Variant) As Variant
If IsError(v) Then
Valor = ""
ElseIf VarType(v) = vbString Then
Valor = Trim$(v)
Else
Valor = v
End If
End Function
Private Function Limpiar(ByVal valor As Variant) As String
If IsError(valor) Then Limpiar = "" Else Limpiar = Trim$(CStr(valor & ""))
End Function
La pieza que
lo conecta todo.
modUtilidades.bas lee la hoja Config, protege el estado de Excel, construye nombres de archivo válidos y deja registro. Las cinco herramientas lo necesitan. Impórtalo una sola vez por libro.
Option Explicit
' =====================================================================
' modUtilidades - Funciones compartidas por todas las automatizaciones
'
' Importalo SIEMPRE junto con el modulo de la herramienta que quieras
' usar (Alt+F11 > Archivo > Importar archivo). Contiene:
' - GuardarEstado / RestaurarEstado: apaga el refresco de pantalla y el
' calculo mientras trabaja la macro y lo deja como estaba.
' - LeerConfig / ConfigLong / ConfigBool: lectura de la hoja "Config"
' (columna A = clave, columna B = valor). Asi ninguna ruta, cuenta ni
' asunto queda escrito en el codigo.
' - NombreArchivoSeguro: nombre de archivo valido en Windows.
' - ComprobarPDF: detecta PDF truncados antes de copiarlos o enviarlos.
' - RegistroCrear / RegistroAnotar: registro TSV de lo que se ha hecho.
' - Progreso: barra de estado como mucho una vez por segundo.
' - RellenarPlantilla: sustituye {A}, {B}... por el valor de la columna.
' - Aviso / Confirmar: cuadros de dialogo; con SinMensajes = SI en
' Config no se abre ninguno (para ejecutar desde un script).
'
' >> ADAPTAR: si tu hoja de configuracion se llama de otra forma, cambia
' el valor por defecto del parametro "hoja" en LeerConfig.
' =====================================================================
' ---------- Estado de la aplicacion ----------
Public Type EstadoExcel
Guardado As Boolean
ScreenUpdating As Boolean
EnableEvents As Boolean
Calculation As XlCalculation
StatusBar As Variant
EnableCancelKey As Long
DisplayAlerts As Boolean
End Type
Public Sub GuardarEstado(ByRef e As EstadoExcel)
With Application
e.ScreenUpdating = .ScreenUpdating
e.EnableEvents = .EnableEvents
e.Calculation = .Calculation
e.StatusBar = .StatusBar
e.EnableCancelKey = .EnableCancelKey
e.DisplayAlerts = .DisplayAlerts
e.Guardado = True
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.EnableCancelKey = xlErrorHandler
End With
End Sub
Public Sub RestaurarEstado(ByRef e As EstadoExcel)
If Not e.Guardado Then Exit Sub
On Error Resume Next
With Application
.ScreenUpdating = e.ScreenUpdating
.EnableEvents = e.EnableEvents
.Calculation = e.Calculation
.StatusBar = e.StatusBar
.EnableCancelKey = e.EnableCancelKey
.DisplayAlerts = e.DisplayAlerts
End With
On Error GoTo 0
e.Guardado = False
End Sub
' ---------- Configuracion en hoja ----------
' La hoja "Config" tiene dos columnas: A = clave, B = valor.
' Asi ninguna ruta, cuenta o asunto queda escrito en el codigo.
Public Function LeerConfig(ByVal clave As String, Optional ByVal obligatorio As Boolean = True, _
Optional ByVal porDefecto As String = "", _
Optional ByVal hoja As String = "Config") As String
Dim ws As Worksheet, celda As Range
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(hoja)
On Error GoTo 0
If ws Is Nothing Then
If obligatorio Then Err.Raise vbObjectError + 1, , "Falta la hoja de configuracion '" & hoja & "'."
LeerConfig = porDefecto
Exit Function
End If
Set celda = ws.Columns(1).Find(What:=clave, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not celda Is Nothing Then
If IsError(ws.Cells(celda.Row, 2).Value) Then Err.Raise vbObjectError + 2, , "Valor no valido en Config '" & clave & "'."
LeerConfig = Trim$(CStr(ws.Cells(celda.Row, 2).Value))
End If
If Len(LeerConfig) = 0 Then
If obligatorio Then Err.Raise vbObjectError + 2, , "Falta el valor de configuracion '" & clave & "' en la hoja " & hoja & "."
LeerConfig = porDefecto
End If
End Function
Public Function ConfigLong(ByVal clave As String, Optional ByVal porDefecto As Long = 0) As Long
Dim v As String
v = LeerConfig(clave, False, CStr(porDefecto))
If IsNumeric(v) Then ConfigLong = CLng(v) Else ConfigLong = porDefecto
End Function
Public Function ConfigBool(ByVal clave As String, Optional ByVal porDefecto As Boolean = False) As Boolean
Dim v As String
v = UCase$(LeerConfig(clave, False, IIf(porDefecto, "SI", "NO")))
ConfigBool = (v = "SI" Or v = "S" Or v = "TRUE" Or v = "VERDADERO" Or v = "1")
End Function
' ---------- Hojas y rangos ----------
Public Function UltimaFila(ByVal ws As Worksheet, Optional ByVal columna As Variant = 1) As Long
UltimaFila = ws.Cells(ws.Rows.Count, columna).End(xlUp).Row
End Function
Public Function ColumnaANumero(ByVal letraONumero As String) As Long
Dim i As Long, s As String, n As Long
s = UCase$(Trim$(letraONumero))
If IsNumeric(s) Then
ColumnaANumero = CLng(s)
Exit Function
End If
For i = 1 To Len(s)
If Mid$(s, i, 1) < "A" Or Mid$(s, i, 1) > "Z" Then Err.Raise vbObjectError + 7, , "Columna no valida: " & letraONumero
n = n * 26 + (Asc(Mid$(s, i, 1)) - 64)
Next i
If n < 1 Or n > 16384 Then Err.Raise vbObjectError + 7, , "Columna no valida: " & letraONumero
ColumnaANumero = n
End Function
' ---------- Nombres de archivo ----------
' Une las partes con espacios, quita caracteres no validos en Windows y
' rechaza nombres vacios o reservados. NO trunca ni cambia identificadores.
Public Function NombreArchivoSeguro(ByVal extension As String, ParamArray partes() As Variant) As String
Dim s As String, i As Long, c As Variant, k As Long, raiz As String
For i = LBound(partes) To UBound(partes)
If Len(Trim$(CStr(partes(i) & ""))) > 0 Then
If Len(s) > 0 Then s = s & " "
s = s & Trim$(CStr(partes(i)))
End If
Next i
s = Replace(s, "/", "_")
For Each c In Array("\", ":", "*", "?", """", "<", ">", "|")
s = Replace(s, CStr(c), "")
Next c
For k = 0 To 31
s = Replace(s, Chr$(k), "")
Next k
s = Trim$(s)
Do While Right$(s, 1) = "."
s = Left$(s, Len(s) - 1)
Loop
If Len(Trim$(Replace(s, ".", ""))) = 0 Then
Err.Raise vbObjectError + 112, , "Nombre de archivo vacio o no valido."
End If
raiz = UCase$(Trim$(Split(s, ".")(0)))
Select Case raiz
Case "CON", "PRN", "AUX", "NUL", "CONIN$", "CONOUT$", _
"COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", _
"LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9"
Err.Raise vbObjectError + 113, , "Nombre reservado por Windows: " & s
End Select
If Left$(extension, 1) <> "." Then extension = "." & extension
NombreArchivoSeguro = s & extension
End Function
' ---------- Dialogos ----------
Public Function ElegirCarpeta(ByVal titulo As String, Optional ByVal inicial As String = "") As String
With Application.FileDialog(4) ' msoFileDialogFolderPicker
.Title = titulo
.AllowMultiSelect = False
If Len(inicial) > 0 Then .InitialFileName = inicial
If .Show = -1 Then ElegirCarpeta = .SelectedItems(1)
End With
End Function
' ---------- Comprobaciones de archivos ----------
Public Sub ComprobarArchivoExiste(ByVal fso As Object, ByVal ruta As String)
If Not fso.FileExists(ruta) Then Err.Raise vbObjectError + 114, , "Falta el archivo: " & ruta
If fso.GetFile(ruta).Size = 0 Then Err.Raise vbObjectError + 115, , "Archivo vacio: " & ruta
End Sub
' Comprobacion basica de truncamiento (cabecera %PDF- y %%EOF al final).
Public Sub ComprobarPDF(ByVal ruta As String)
Dim canal As Integer, abierto As Boolean, largo As Long, cola As Long
Dim cabecera As String, finalPDF As String, numeroError As Long, descripcionError As String
On Error GoTo FalloPDF
canal = FreeFile
Open ruta For Binary Access Read As #canal
abierto = True
largo = LOF(canal)
If largo < 10 Then Err.Raise vbObjectError + 214, , "PDF vacio o incompleto: " & ruta
cabecera = Space$(5)
Get #canal, 1, cabecera
cola = largo
If cola > 2048 Then cola = 2048
finalPDF = Space$(cola)
Get #canal, largo - cola + 1, finalPDF
Close #canal
abierto = False
If cabecera <> "%PDF-" Or InStr(1, finalPDF, "%%EOF", vbBinaryCompare) = 0 Then
Err.Raise vbObjectError + 215, , "El PDF parece incompleto: " & ruta
End If
Exit Sub
FalloPDF:
numeroError = Err.Number: descripcionError = Err.Description
On Error Resume Next
If abierto Then Close #canal
On Error GoTo 0
Err.Raise numeroError, "ComprobarPDF", descripcionError
End Sub
' ---------- Registro TSV ----------
Public Sub RegistroCrear(ByVal fso As Object, ByVal ruta As String)
Dim archivo As Object
Set archivo = fso.CreateTextFile(ruta, False, True) ' UTF-16, Excel lo abre bien
archivo.WriteLine "Fecha" & vbTab & "Fila" & vbTab & "Estado" & vbTab & "Correo" & vbTab & "Archivo" & vbTab & "Detalle"
archivo.Close
End Sub
Public Sub RegistroAnotar(ByVal fso As Object, ByVal ruta As String, ByVal fila As Long, _
ByVal estado As String, ByVal correo As String, ByVal archivoRuta As String, ByVal detalle As String)
Dim archivo As Object
If Len(ruta) = 0 Then Exit Sub
Set archivo = fso.OpenTextFile(ruta, 8, False, -1)
archivo.WriteLine Format$(Now, "yyyy-mm-dd hh:nn:ss") & vbTab & fila & vbTab & estado & vbTab & _
CampoTSV(correo) & vbTab & CampoTSV(archivoRuta) & vbTab & CampoTSV(detalle)
archivo.Close
End Sub
Public Function CampoTSV(ByVal s As String) As String
s = Replace(Replace(Replace(s, vbTab, " "), vbCr, " "), vbLf, " ")
If Len(s) > 0 Then
If InStr(1, "=+-@", Left$(s, 1), vbBinaryCompare) > 0 Then s = "'" & s
End If
CampoTSV = s
End Function
' ---------- Tiempo y progreso ----------
Public Function SegundosDesde(ByVal marca As Double) As Double
Dim t As Double
t = CDbl(Timer) - marca
If t < 0 Then t = t + 86400#
SegundosDesde = t
End Function
' Actualiza la barra de estado como mucho una vez por segundo.
Public Sub Progreso(ByVal texto As String, ByVal actual As Long, ByVal total As Long)
Static ultimaMarca As Double
If actual = 1 Or actual = total Or SegundosDesde(ultimaMarca) >= 1 Then
Application.StatusBar = texto & ": " & actual & " / " & total
ultimaMarca = CDbl(Timer)
DoEvents
End If
End Sub
' ---------- Outlook ----------
Public Function ObtenerOutlook() As Object
Dim app As Object
On Error Resume Next
Set app = GetObject(, "Outlook.Application")
On Error GoTo 0
If app Is Nothing Then Set app = CreateObject("Outlook.Application")
Set ObtenerOutlook = app
End Function
' Sustituye {A}, {B}, {AO}... por el valor de esa columna en la fila dada.
Public Function RellenarPlantilla(ByVal plantilla As String, ByVal ws As Worksheet, ByVal fila As Long) As String
Dim resultado As String, ini As Long, fin As Long, col As String
resultado = plantilla
ini = InStr(1, resultado, "{")
Do While ini > 0
fin = InStr(ini, resultado, "}")
If fin = 0 Then Exit Do
col = Mid$(resultado, ini + 1, fin - ini - 1)
If Len(col) >= 1 And Len(col) <= 3 And Not col Like "*[!A-Za-z]*" And EsColumnaValida(col) Then
resultado = Left$(resultado, ini - 1) & CStr(ws.Cells(fila, ColumnaANumero(col)).Value) & Mid$(resultado, fin + 1)
ini = InStr(ini + 1, resultado, "{")
Else
ini = InStr(fin + 1, resultado, "{")
End If
Loop
RellenarPlantilla = resultado
End Function
Private Function EsColumnaValida(ByVal col As String) As Boolean
On Error Resume Next
EsColumnaValida = (ColumnaANumero(col) > 0)
On Error GoTo 0
End Function
' ---------- Mensajes ----------
' Con SinMensajes = SI en Config (util para ejecutar las macros desde un script
' o para grabar una demo) el aviso no abre un cuadro: se escribe en la barra de
' estado y en el archivo ultimo_aviso.txt junto al libro.
Public Sub Aviso(ByVal texto As String, Optional ByVal icono As Long = vbInformation)
Dim canal As Integer
If ConfigBool("SinMensajes", False) Then
On Error Resume Next
Application.StatusBar = Left$(Replace(texto, vbCrLf, " | "), 250)
canal = FreeFile
Open ThisWorkbook.Path & "\ultimo_aviso.txt" For Output As #canal
Print #canal, Format$(Now, "yyyy-mm-dd hh:nn:ss")
Print #canal, texto
Close #canal
On Error GoTo 0
Else
MsgBox texto, icono
End If
End Sub
' Confirmacion Si/No; con SinMensajes = SI se da por aceptada.
Public Function Confirmar(ByVal texto As String, ByVal titulo As String) As Boolean
If ConfigBool("SinMensajes", False) Then
Confirmar = True
Else
Confirmar = (MsgBox(texto, vbYesNo + vbQuestion + vbDefaultButton2, titulo) = vbYes)
End If
End Function
Un poco de contexto.
Y manos a la hoja.
¿Qué necesito para usarlas?
Excel de escritorio con VBA. La macro de documentos también necesita Word y, para crear correos, Outlook clásico con una cuenta configurada. Cada hoja indica sus requisitos.
¿Los vídeos muestran resultados reales?
Sí. Utilizan datos inventados y resultados reales de cada macro. Los tiempos indicados son los medidos en las demos; dependen del equipo y los datos.
¿Puedo adaptar el código?
Sí. Puedes copiar o descargar cada módulo. Los comentarios >> ADAPTAR señalan los puntos previstos para cambiar. Prueba siempre con una copia de tus datos. Las macros se ofrecen sin garantía.
¿Quién está detrás?
Un proyecto de Sterium AI: ideas y herramientas para compartir, probar y mejorar. ¿Tienes una idea o quieres contar cómo te ha ido? Escríbeme.