Macro Buscar en una tabla y pegar ordenado en celdas seguidas
Hace tiempo hice esta pregunta pero no me pudieron ayudar. Lo intento de nuevo a ver si alguien me puede echar una mano. El caso es que me dan la tabla superior de la siguiente imagen y yo tengo que crear otra como la segunda:
Ca
Cada empleado (unos 150) elige seis semanas del año de vacaciones, luego según unos criterios de preferencia rotatorios, se le asignan y se crea la tabla de arriba. Ahora yo tengo que pasar otra tabla con el listado de empleados en una columna, seguido por cada una de las 6 semanas que les han sido asignadas.
Agradecería enormemente si alguien me pudiese ayudar a simplificar el proceso y que no tuviese que ir buscando y pegando de una en una las celdas, ya que son 150 empleados.
1 Respuesta
H o l a: Te anexo la macro.
Deberás tener 2 hojas, en la primera hoja vas a poner tus datos de los empleados distribuidos en las 52 semanas, y en la segunda hoja quedarán los resultados, por ejemplo:
En la celda A1 empieza la "semana1".
Entonces en la macro tienes que poner 3 datos, el nombre de la hoja1, el nombre de la hoja2 y la celda donde empieza la semana1 en esta parte:
Set h1 = Sheets("tabla1") 'tabla origen
Set h2 = Sheets("tabla2") 'tabla destino
celda = "A1" 'celda inicial de datosYo le puse a mis hojas "tabla1" y "tabla2" pero tu le puedes poner el nombre que quieras.
La macro:
Sub Semanas()
'Por.Dante Amor
Set h1 = Sheets("tabla1") 'tabla origen
Set h2 = Sheets("tabla2") 'tabla destino
celda = "A1" 'celda inicial de datos
'
Set cd = h1.Range("A1")
f = cd.Cells(1, 1).Row
c = cd.Cells(1, 1).Column
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 4
h2.Range("A4:G" & u2).ClearContents
'
For j = c To h1.Cells(f, Columns.Count).End(xlToLeft).Column
For i = f + 1 To h1.Cells(Rows.Count, c).End(xlUp).Row
emp = h1.Cells(i, j)
If emp <> "" Then
Set b = h2.Columns("A").Find(emp, lookat:=xlWhole)
If Not b Is Nothing Then
uc = h2.Cells(b.Row, Columns.Count).End(xlToLeft).Column + 1
h2.Cells(b.Row, uc) = h1.Cells(f, j)
Else
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
If u2 < 4 Then u2 = 4
h2.Cells(u2, "A") = emp
h2.Cells(u2, "B") = h1.Cells(f, j)
End If
End If
Next
Next
MsgBox "Fin"
End SubLos resultados quedarán en la hoja2 en las columnas de la A a la G:
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
