LISTAR TODOS LOS ARCHIVOS DE UNA CARPETA Y SUS SUBCARPETAS CON VBA

Hola a todos! Espero que todo vaya bien. 🙂

No tenía pensado escribir hoy un post, pero al final me he animado y aquí estoy!. El motivo de no querer postear es que llevo todo el fin de semana sumergido en los algoritmos genéticos y necesito un poco de descanso.

Pero como ya sabéis que trabajar en Excel para mi es una afición, pues no me ha costado demasiado decidirme.

Hoy vamos a tratar sobre la posibilidad de “listar” todo el contenido de archivos que podamos tener en una carpeta y sus subcarpetas. Listaremos cada archivo con el directorio completo y en formato hipervínculo, de manera que podamos luego buscar el archivo con solo pulsar el enlace.

Esta es una consulta que me llegó hace un año aproximadamente y hoy me he acordado de ella, así que os dejo la macro que le envié al lector como solución.

Como ejemplo me utilizaré a mi mismo. Como es obvio, todos los contenidos, macros, imágenes … etc, de esta web están almacenados en varias copias de seguridad, en varios equipos y también en la nube, imaginad que quiero listar todos los archivos que tengo en Excel Signum en uno de mis equipos, ¿cómo lo hago?.

Pues afortunadamente para mi, tengo esta macro que me ayudará con la tarea. En realidad una macro y una función, aquí os las dejo:

Sub LISTAR_ARCHIVOS()
'Declaramos variables
Dim sFSO As Object, Directorio As String
Dim dir_Archivo As Variant
'Abrimos ventana de diálogo para seleccionar carpeta
Set dir_Archivo = Application.FileDialog(msoFileDialogFolderPicker)
dir_Archivo.Show
'Si no seleccionamos nada salimos del proceso
If dir_Archivo.SelectedItems.Count = 0 Then
Exit Sub
End If
'Capturamos el directorio del archivo seleccionado
Directorio = dir_Archivo.SelectedItems(1)
'Creamos objeto y ejecutamos función Carpeta
Set sFSO = CreateObject("Scripting.FileSystemObject")
CARPETA sFSO.GetFolder(Directorio)
End Sub

Y esta es la función:

Function CARPETA(ByVal nCarpeta)
'Declaramos variables
Dim j As Long, Subcarpeta As Object
'Con la hoja activa
With ActiveSheet
'Limpiamos columna A si contiene datos
Fin = Application.CountA(ActiveSheet.Range("A:A"))
If Fin > 1 Then .Range("A2:A" & Fin).Clear
'Iniciamos dos loop, uno que recorre las carpetas
For Each Subcarpeta In nCarpeta.SubFolders
CARPETA Subcarpeta
Next
j = Application.CountA(.Range("A:A")) + 1
'y otro que recorre los archivos y los indexa y activa hipervínculo
For Each File In nCarpeta.Files
.Cells(j, 1).Select
.Hyperlinks.Add Anchor:=Selection, Address:=File.Path, TextToDisplay:=File.Path
j = j + 1
Next
End With
End Function

Una vez que pulsamos en la macro, nos aparecerá un cuadro de diálogo que nos va a permitir seleccionar la carpeta:

LISTAR TODOS LOS ARCHIVOS DE UNA CARPETA Y SUS SUBCARPETAS CON VBA

Una vez que pulsamos aceptar, entonces se comenzarán a listar todos los archivos en la hoja activa (en este caso la hoja1):

LISTAR TODOS LOS ARCHIVOS DE UNA CARPETA Y SUS SUBCARPETAS CON VBA1

Como podéis observar, esta es una muestra de los archivos de seguridad que tengo de Excel Signum y donde además hemos insertado en cada uno un hipervínculo con la ruta hasta el archivo real.

Se podría mostrar solo el nombre del archivo sin mostrar toda la ruta, simplemente se tendría que modificar TextToDisplay:=File.Path por TextToDisplay:=File.Name

Existen muchos tipos y formas de obtener estos datos con programación, esta es solo una forma, pero es la que suelo usar 🙂

Espero que os resulte útil, y me alegro de haber escrito finalmente el post.

Descarga el archivo de ejemplo pulsando en: LISTAR TODOS LOS ARCHIVOS DE UNA CARPETA Y SUS SUBCARPETAS CON VBA

 

Anuncios

EXTRAER REGISTROS ÚNICOS DE UN RANGO DE DATOS

Aunque normalmente no tengo mucho tiempo, a veces entro en algunos foros de Excel y contesto algunas de las preguntas que realizan los lectores. Esto es muy positivo, siempre encuentras nuevas ideas para desarrollar y hechas una mano a otras personas.

La última consulta que respondí iba sobre la posibilidad de extraer registros únicos pero no de una columna sino de un rango de datos. Es decir, seleccionar un rango de celdas y extraer los registros únicos.

Esta tarea se puede hacer de varias formas, en esta ocasión lo implementaré con matrices en VBA y finalmente aplicaremos quitar duplicados.

Como siempre vamos a usar un ejemplo: voy a pegar varias columnas (tres, por ejemplo) sobre las que seleccionaré el rango sobre el que extraer la información:

EXTRAER REGISTROS UNICOS DE UN RANGO DE DATOS1

A continuación debemos pegar la macro que realizará el trabajo:

Sub EXTRAER_UNICOS()
'Definimos variables
Dim i As Long, fin As Long
Dim rng As Range, celda As Range
Dim final As Long
Dim matriz() As Variant
'Desactivamos actualización de pantalla
Application.ScreenUpdating = False
'Trabajamos con la hoja activa
With ActiveSheet
'Limpiamos datos en la columna E
.Columns("E:E").ClearContents
'Capturamos selección y contamos registros
i = 1
Set rng = Selection
fin = rng.Count
'Redimensionamos la matriz
ReDim matriz(1 To fin)
'Con un loop grabamos los datos de cada celda
'y los pasamos a la columna E

For Each celda In rng
matriz(i) = celda.Value
i = i + 1
Next celda
For i = LBound(matriz) To UBound(matriz)
.Cells(i, 5) = matriz(i)
Next i
'Eliminamos duplicados de la columna E
final = .Cells(Rows.Count, "E").End(xlUp).Row
'Si no hay datos en la columna E salimos del proceso
If final = 1 Then Exit Sub
.Range("E1:E" & final).RemoveDuplicates Columns:=1, Header:=xlNo
'Ordenamos los datos, centrados y ascendentes
With .Columns("E:E")
.Select
.HorizontalAlignment = xlCenter
End With
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("E1:E" & final), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("E1:E" & final)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
.Range("E1").Select
End With
Application.ScreenUpdating = True
End Sub

Ahora que ya tenemos la macro, solo tenemos que seleccionar los datos y pulsar en el botón de comando. El resultado lo pasará a la columna “E” o “5” (podéis especificar el destino que mejor se adapte a vuestras necesidades indicándolo en el código).

Y ya tenemos los datos:

EXTRAER REGISTROS UNICOS DE UN RANGO DE DATOS2

Dado que estamos trabajando con matrices, debéis tener en cuenta que tienen ciertos límites (por ejemplo, si seleccionamos toda la hoja, mostrará un error).

Y eso es todo por hoy, espero que os sea de utilidad. Por supuesto, en este ejemplo obtenemos los datos de una selección, pero se podría definir un rango perfectamente.

Descarga el archivo de ejemplo pulsando en: EXTRAER REGISTROS ÚNICOS DE UN RANGO DE DATOS

GRABAR EL NOMBRE DE USUARIO DE WINDOWS CUANDO ABRIMOS Y CERRAMOS NUESTRO ARCHIVO EXCEL

Últimamente estoy recibiendo bastantes consultas, algunas son demasiado extensas como para realizar un ejemplo en un post, pero otras son perfectas para realizar un post.

La consulta que me enviaron ayer trata sobre la posibilidad de obtener el usuario de Windows con VBA y utilizarlo en una archivo compartido para identificar las personas que acceden (y también obtener la misma información en el momento que cierran en archivo).

Además aprovecho para agregar dos datos más a la información: la fecha y la hora.

En realidad son dos macros, una para la apertura y otra para el cierre. Para cuando abrimos el archivo, creo que lo que mejor se ajusta es grabar el código en ThisWorkbook  y utilizar el evento Open. La macro que debéis pegar es esta:

Private Sub Workbook_Open()
'Declaramos variables
Dim sNetwork As Object
Dim i As Integer, fin As Integer
'Obtenemos nombre del usuario del equipo
Set sNetwork = CreateObject("WScript.Network")
UserName = sNetwork.UserName
'Mostramos los datos en la Hoja1 al abrir el archivo
With Sheets("Hoja1")
fin = Application.CountA(Sheets("Hoja1").Range("A:A"))
For i = 2 To fin
If .Cells(i, 1) = "" Then
Final = i
Exit For
End If
Next
'Nombre de usuario
.Cells(i, 1) = UserName
'Fecha
.Cells(i, 2) = Date
'Hora
.Cells(i, 3) = Format(Time, "h:mm:ss")
'Indicamos que la acción es de apertura del archivo
.Cells(i, 4) = "ABRE ARCHIVO"
End With
'Liberamos variables
Set sNetwork = Nothing
End Sub

Con esta macro vamos a obtener la siguiente información:

GRABAR EL NOMBRE DE USUARIO DE WINDOWS CUANDO ABRIMOS Y CERRAMOS NUESTRO ARCHIVO EXCEL

Para grabar los datos con el cierre del archivo vamos a utilizar la siguiente macro:

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
'Declaramos variables
Dim sNetwork As Object
Dim i As Integer, fin As Integer
'Obtenemos nombre del usuario del equipo
Set sNetwork = CreateObject("WScript.Network")
UserName = sNetwork.UserName
'Mostramos los datos en la Hoja1 al cerrar el archivo
With Sheets("Hoja1")
fin = Application.CountA(Sheets("Hoja1").Range("A:A"))
For i = 2 To fin
If .Cells(i, 1) = "" Then
Final = i
Exit For
End If
Next
'Nombre de usuario
.Cells(i, 1) = UserName
'Fecha
.Cells(i, 2) = Date
'Hora
.Cells(i, 3) = Format(Time, "h:mm:ss")
'Indicamos que la acción es de apertura del archivo
.Cells(i, 4) = "CIERRA EXCEL"
End With
'Liberamos variables
Set sNetwork = Nothing
ActiveWorkbook.Save
End Sub

Aquí vamos a utilizar el evento Workbook_WindowDeactivate y además, guardaremos el archivo desactivando con ActiveWorkbook.Save, este es el resultado:

GRABAR EL NOMBRE DE USUARIO DE WINDOWS CUANDO ABRIMOS Y CERRAMOS NUESTRO ARCHIVO EXCEL1

Obviamente, si abrimos y cerramos varias  veces el archivo tendremos varios registros indicando nuestra actividad.

El archivo os lo dejo en blanco, de manera que cuando lo abráis aparecerán vuestros datos grabados en la Hoja1 del archivo. El archivo se puede cambiar a compartido si es necesario, las macros funcionarán perfectamente (probado en Excel 2010 y Excel 2016).

Espero que sea de vuestro interés 🙂

Descarga el archivo de ejemplo pulsando en: GRABAR EL NOMBRE DE USUARIO DE WINDOWS CUANDO ABRIMOS Y CERRAMOS NUESTRO ARCHIVO EXCEL

 

VERIFICAR EL ESTADO DE LOS ENLACES A OTROS ARCHIVOS DESDE NUESTRO PROYECTO

Hola a todos:

Esta semana un lector me enviaba la siguiente consulta: Se trata de cómo se podría verificar en un archivo si los vínculos con otros archivos, utilizados en fórmulas, referencias, etc, son correctos y no se han eliminado o modificado.

Este es un tema muy recurrente cuando trabajamos con Excel y en entornos en los que compartimos archivos y datos con otros compañeros. Es posible que por error alguien elimine un archivo que está vinculado a nuestro proyecto y no nos demos cuenta hasta que sea demasiado tarde.

Pues bien, para estos casos en concreto, para poder ver e identificar los archivos vinculados y su estado, se puede realizar con VBA un pequeño proceso que extraiga esta información.

Pero antes vamos a desarrollar un ejemplo. Imaginad que tenemos un archivo con los siguientes ID’s y nombres de campo:

VERIFICAR EL ESTADO DE LOS ENLACES A OTROS ARCHIVOS DESDE NUESTRO PROYECTO

y además una serie de archivos donde se almacena la información por tipo de campo:

VERIFICAR EL ESTADO DE LOS ENLACES A OTROS ARCHIVOS DESDE NUESTRO PROYECTO2

Dado que tenemos que componer nuestra base de datos con la información del resto de archivos, vamos a utilizar la función Buscarv() para traernos la información.

Una vez que la tenemos, el resultado es el siguiente:

VERIFICAR EL ESTADO DE LOS ENLACES A OTROS ARCHIVOS DESDE NUESTRO PROYECTO3

Como podéis ver, las fórmulas funcionan correctamente y los vinculos no contienen errores. Pero resulta que un compañero de nuestro equipo, por equivacación, ha eliminado el archivo que contiene los nombres y, por si fuese poco, otra compañera ha eliminado la hoja del archivo “ASIGNATURAS” que contenía los datos.

Así se presentaría nuestra información una vez que abrimos el archivo. (en el caso de las hoja eliminada al principio nos aparecerá un error de referencia #¡REF! y al evaluar el error se convertirá en #N/A). Pero en el caso de los nombres no nos vamos a dar cuenta, dado que Excel se queda con el valor anterior.

Para realizar el control en nuestro archivo, utilizaremos la siguiente macro:

Sub VERIFICAR_LINKS_EXTERNOS()
'Declaramos variables
Dim i As Integer, infoLink As Integer
Dim eLinks As Variant
Dim MsgLnk As String
Dim fin As Integer
'Borramos datos en Hoja Resumen
Sheets("RESUMEN").Select
With Sheets("RESUMEN")
fin = Application.CountA(.Range("A:A"))
If fin > 1 Then .Range("A2:B" & fin).ClearContents
End With
'si no existen referencias a otros archivos salimos del proceso
eLinks = ThisWorkbook.LinkSources(xlExcelLinks)
If IsEmpty(eLinks) Then
MsgBox ("NO EXISTEN LINK EXTERNOS EN EL LIBRO")
Exit Sub
End If
'Con un bucle verificamos el estado de cada link e identificamos
'su estatus
For i = 1 To UBound(eLinks)
infoLink = ActiveWorkbook.LinkInfo(eLinks(i), xlLinkInfoStatus)
If infoLink = xlLinkStatusMissingFile Then
MsgLnk = "Falta el archivo de origen"
ElseIf infoLink = xlLinkStatusMissingSheet Then
MsgLnk = "Falta la hoja del archivo de origen"
ElseIf infoLink = xlLinkStatusCopiedValues Then
MsgLnk = "Valores copiados"
ElseIf infoLink = xlLinkStatusIndeterminate Then
MsgLnk = "No se puede determinar el estado"
ElseIf infoLink = xlLinkStatusInvalidName Then
MsgLnk = "El nombre no es válido"
ElseIf infoLink = xlLinkStatusNotStarted Then
MsgLnk = "No iniciado"
ElseIf infoLink = xlLinkStatusOld Then
MsgLnk = "El estado puede no estar actualizado"
ElseIf infoLink = xlLinkStatusSourceNotCalculated Then
MsgLnk = "No se ha calculado todavía"
ElseIf infoLink = xlLinkStatusSourceNotOpen Then
MsgLnk = "El documento de origen no está abierto"
ElseIf infoLink = xlLinkStatusSourceOpen Then
MsgLnk = "El documento de origen está abierto"
ElseIf infoLink = xlLinkStatusOK Then
MsgLnk = "Sin errores"
End If
'Pasamos los datos a la hoja RESUMEN
With Sheets("RESUMEN")
.Cells(1, 1) = "RUTA ARCHIVO"
.Cells(1, 2) = "MENSAJE"
.Cells(i + 1, 1) = eLinks(i)
.Cells(i + 1, 2) = MsgLnk
End With
'Mostramos datos en la ventana de Inmediato en nuestro editor de VBA
Debug.Print "Ruta = "; eLinks(i) & " | Mensaje = "; MsgLnk
Next
End Sub

El resultado es el siguiente:

VERIFICAR EL ESTADO DE LOS ENLACES A OTROS ARCHIVOS DESDE NUESTRO PROYECTO4

En aquellos casos que o bien han eliminado el archivo o una hoja, tenemos información precisa de lo que ha ocurrido y a que archivos afecta. En el resto de casos nos encontraremos con que no hay errores, aunque es posible que si lleváis tiempo sin ejecutar abrir el archivo (lo cual es muy probable), si ejecutáis la información en el momento de abrir, os aparezca el mensaje “El estado puede no estar actualizado“, lo cual indica que es aconsejable actualizar las fórmulas.

Al final de la macro os dejo la posibilidad de ver la misma información en la ventana de Inmediato de vuestro editor de VBA, por si no queréis utilizar la hoja “Resumen”.

He decido poner en la macro, todos los mensajes posibles que Excel puede mostrar, aquí tenéis información sobre este tema: https://msdn.microsoft.com/es-es/library/office/ff196932.aspx

Espero que os resulte de utilidad a la hora de verificar qué archivos están dando problemas o simplemente si todo nuestro trabajo está correctamente vinculado.

Saludos.

PD: cuando ejecutéis la macro en vuestro equipo, el mensaje será para todos los casos “Falta el archivo de origen”, dado que, como es obvio esos archivos están en mi equipo 🙂

Descarga el archivo de ejemplo pulsando en: VERIFICAR EL ESTADO DE LOS ENLACES A OTROS ARCHIVOS DESDE NUESTRO PROYECTO

 

VACIAR TODOS LOS COMBOBOX DE UNA HOJA

Hola a todos:

Hoy escribiré sobre cómo podemos automatizar la tarea de vaciar todos los combobox de nuestra hoja.

Dado que es un ejemplo sencillo no dejaré archivo, con el código es suficiente. Tan solo tenéis que copiarlo y pegarlo en un módulo estándar y realizar la prueba:

Sub VACIAR_COMBOS()
With ActiveSheet
'Por cada objeto que sea un combobox limpiamos contenido
For Each objeto In .OLEObjects
If objeto.OLEType = xlOLEControl Then
If TypeName(objeto.Object) = "ComboBox" Then
objeto.Object.Clear
End If
End If
Next
End With
End Sub

Como podéis ver, lo único que hacemos es pasar un “for – each” por todos los objetos de la hoja y cuando se trata del tipo especificado, limpia o vacía el contenido.

Es una macro sencilla y si tenéis aplicaciones que requieren  vaciar todos los combos, podéis hacerlo muy rápido con este código.

Si tuviésemos listbox en lugar de combobox, solo tendréis que sustituir listbox por combobox en la macro:

Sub VACIAR_LISTBOX()
With ActiveSheet
'Por cada objeto que sea un listbox limpiamos contenido
For Each objeto In .OLEObjects
If objeto.OLEType = xlOLEControl Then
If TypeName(objeto.Object) = "ListBox" Then
objeto.Object.Clear
End If
End If
Next
End With
End Sub

Y ya para finalizar, si se tratase de TextBox, solo hemos de modificar el método de limpiar los datos:

Sub VACIAR_TEXTBOX()
With ActiveSheet
'Por cada objeto que sea un textbox limpiamos contenido
For Each objeto In .OLEObjects
If objeto.OLEType = xlOLEControl Then
If TypeName(objeto.Object) = "TextBox" Then
objeto.Object = ""
End If
End If
Next
End With
End Sub

Son pequeñas “pinceladas” que os pueden ser de mucha utilidad para hacer que vuestro código sea más corto y más eficiente.

Y eso es todo por hoy.

Saludos! 🙂

RELLENAR RANGO DE CELDAS VACÍAS CON EL VALOR DE LA CELDA SUPERIOR

Hoy voy a tratar un tema que, aunque pueda parecer menor, no es la primera vez que me lo encuentro cuando realizo trabajos o informes.

El problema surge cuando trabajamos con datos de una tabla dinámica que han sido pegados en una hoja como valores y es necesario rellenar las filas en blanco con el dato de la celda superior que contenga información.

Un ejemplo podría ser este:

RELLENAR RANGO DE CELDAS VACÍAS CON EL VALOR DE LA CELDA SUPERIOR

Es decir, en aquellas celdas que se encuentran en blanco rellenarlas con el dato correspondiente, licenciado, diplomado, etc.

Para hacer este trabajo, podemos hacerlo o bien con macros o bien utilizando funciones de la hoja Excel.

Si queremos hacerlo manualmente con funciones:  nos posicionamos en una celda de la columna que contiene las celdas en blanco, a continuación, (sin dejar de seleccionar la celda), vamos a la pestaña de INICIO > BUSCAR Y SELECCIONAR > IR A ESPECIAL:

RELLENAR RANGO DE CELDAS VACÍAS CON EL VALOR DE LA CELDA SUPERIOR2

y marcamos la opción “Celdas en Blanco“:

RELLENAR RANGO DE CELDAS VACÍAS CON EL VALOR DE LA CELDA SUPERIOR3

Ahora que tenemos las celdas en blanco seleccionadas, (y deben seguir seleccionadas):

RELLENAR RANGO DE CELDAS VACÍAS CON EL VALOR DE LA CELDA SUPERIOR4

Nos situamos en la barra de fórmulas y tecleamos =A2 que se corresponde con la última fila con datos y pulsamos CONTROL + INTRO.

RELLENAR RANGO DE CELDAS VACÍAS CON EL VALOR DE LA CELDA SUPERIOR5

El resultado es el siguiente:

RELLENAR RANGO DE CELDAS VACÍAS CON EL VALOR DE LA CELDA SUPERIOR6

Pero si por alguna razón necesitamos realizar esta tarea con una macro, por ejemplo para automatizar un proceso, lo podemos hacer con dos métodos diferentes, que en realidad hacen lo mismo.

La primera macro (METODO1) realiza los mismos pasos que hemos hecho manualmente, y además deja los datos como valores, sin la fórmula:

Sub Metodo1()
'Defininimos variables
Dim Fin%, x%, Rng%
With Sheets("Hoja1")
'Grabamos longitud del rango y contamos celdas en blanco
Fin = Application.CountA(.Range("B:B"))
x = WorksheetFunction.CountBlank(Range("A2:A" & Fin))
'Si hay celdas en blanco
If x > 0 Then
'Seleccionamos celdas en blanco
.Range("A2:A" & Fin).SpecialCells(xlCellTypeBlanks).Select
'Aplicamos fórmula en cada celda, hace referencia al valor anterior
Selection.FormulaR1C1 = "=R[-1]C"
'Seleccionamos todo el rango y lo pasamos a valores
Rng = Application.CountA(.Range("A:A"))
.Range("A2:A" & Rng).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
End With
End Sub

La segunda macro (METODO2) es mucho más sencilla y realiza el trabajo mediante un loop haciendo referencia a la última celda con datos:

Sub Metodo2()
'Definimos variables
Dim i%, Fin%
With Sheets("Hoja2")
Fin = Application.CountA(.Range("B:B"))
'Mediante un bucle indicamos que si una celda está vacía
'el valor sea el de la celda anterior.

For i = 2 To Fin
If .Cells(i, 1) = "" Then .Cells(i, 1) = .Cells(i - 1, 1)
Next
End With
End Sub

Con las dos códigos obtendremos el mismo resultado. También debemos tener en cuenta la primera opción (manual) que para casos concretos es la más rápida y eficaz.

Descarga el archivo de ejemplo pulsando en: RELLENAR RANGO DE CELDAS VACÍAS CON EL VALOR DE LA CELDA SUPERIOR

EJECUTAR UN BUCLE EN UN RANGO DE FILAS FILTRADAS

Hola a todos!.

Hace unos días, un lector me trasladó la pregunta de cómo podría ejecutar un bucle (loop) en un rango de filas filtradas. Esto se puede realizar de diferentes formas, pero para este post quiero aprovechar y realizar un ejercicio completo con un caso práctico.

Imaginad que trabajáis de un teatro y se ha decido que para una función concreta, la asignación de sitios en las diferentes zonas del teatro se hará de una manera determinada:

Nos han enviado un listado (hoja LISTA) en el que aparecen los siguientes campos ID, FECHA, HORA, NOMBRE y LUGAR (zona del teatro), esta es la lista:

EJECUTAR UN BUCLE EN UN RANGO DE FILAS FILTRADAS

Pues bien, lo que se pretende es que asignemos un 50% de la cantidad total del número de solicitudes a cada zona y teniendo en cuenta la fecha más antigua y la hora más antigua de cada petición. Es decir que si el número total de personas que han solicitado un lugar en la Zona Premium es de 122 se marcarán los 61 primeros registros teniendo en cuenta la fecha más antigua y la hora más antigua como criterio.

Para hacer este proceso es necesario realizar varios filtros y posteriormente marcar a los clientes beneficiados. Obviamente, se puede hacer manualmente, pero … ¡el tiempo es oro! y no es cuestión de estar varias horas haciendo este proceso, o lo que es peor, imaginad que a partir de ahora siempre se hará así!.

Por lo tanto, vamos a proponer un sencillo código que nos va a ayudar a realizar esto en un segundo 🙂

Antes de ver la macro, debemos añadir otra hoja en la que vamos a indicar el nombre de todas las zonas del teatro:

EJECUTAR UN BUCLE EN UN RANGO DE FILAS FILTRADAS2

Y ahora, en un módulo estándar pegáis esta macro:

Sub BUCLE_EN_CELDAS_FILTRADAS()
'Definimos variables
Dim Fin As Integer, Final As Integer, nCasos As Integer
Dim nRango As Range, Contador As Integer, n As Integer, Dato As Range
'Desactivamos actualización de pantalla
Application.ScreenUpdating = False
'Limpiamos contenidos en el campo MARCA
With Sheets("LISTA")
Fin = Application.CountA(.Range("A:A"))
Final = Application.CountA(Sheets("ZONAS").Range("A:A"))
If Fin > 1 Then .Range("F2:F" & Fin).ClearContents
'Iniciamos bucle filtrando según ZONA y aplicando el 50 al total de personas
'con esta cifra marcaremos con otro bucle los n casos iniciales

For i = 2 To Final
'Pero antes, ordenamos por fecha, de más antigua a más reciente
nCasos = Round(Application.WorksheetFunction.CountIf(.Range("E2:E" & Fin), Sheets("ZONAS").Cells(i, 1)) * 0.5, 0)
.Range("A1:E" & Fin).AutoFilter Field:=5, Criteria1:=Sheets("ZONAS").Cells(i, 1)
With ActiveWorkbook.Worksheets("LISTA").AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B1:B" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
.Header = xlYes
.Apply
End With
'Ordenamos hora, de más antigua a más reciente
With ActiveWorkbook.Worksheets("LISTA").AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("C1:C" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
.Header = xlYes
.Apply
End With
'Pasamos un segundo bucle para marcar con una X el 50% de los casos seleccionados
Set nRango = .Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
For Each Dato In nRango.Rows
n = 1
Contador = Contador + n
If Contador <= nCasos Then
Dato.Cells(1, 6).Value = "X"
Else
Exit For
End If
Next
Contador = 0
Selection.AutoFilter
Next
End With
'Ordenamos por ZONA y mostramos la información
Range("A1").Select
Selection.AutoFilter
With ActiveWorkbook.Worksheets("LISTA").AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("E1:E" & Fin), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
.Header = xlYes
.Apply
Selection.AutoFilter
End With
Application.ScreenUpdating = True
End Sub

Como podéis observar, realizamos dos tipo de bucle, un for-next y un for each – next. Pero es este último (for each) en el que realmente pasamos un bucle sobre las celdas que hemos filtrado previamente según los parámetros establecidos en los datos del primer bucle.

Pulsamos el botón y tenemos este resultado:

EJECUTAR UN BUCLE EN UN RANGO DE FILAS FILTRADAS3

El código se encarga de filtrar, marcar y presentar los datos ordenador por zonas. En solo un segundo (para 800 registros).

Creo que es un ejercicio muy interesante y que podéis aplicar a multitud de tareas y proyectos. 🙂

Como siempre os dejo el archivo de descarga:

Descarga el archivo de ejemplo pulsando en: EJECUTAR UN BUCLE EN UN RANGO DE FILAS FILTRADAS