Macro en Excel para copiar datos de una hoja a otra cumpliendo cierta condición
La macro debería copiar los datos de actividades (a1, a2, a3, a4, a5) en otra hoja cumpliendo las condiciones de :
-Los porcentajes sin menores a 80% que copie las actividades a otra hoja; así vaya comprobando porcentaje por porcentaje, ejemplo:
Si 30% es menor a 80% que copie "a1" a otra hoja
-A la vez que copie el primero valor mayor o igual a 80% a la otra hojas, ejemplo:
Si a4 como en el cuadro de ejemplo tiene frecuencia 81% y a5 tiene 87%, que solo copie a4 porque es el que tiene el primer valor igual o mayor (81%) como indica la condición.
Con las mismas condiciones anteriores que sombree los porcentajes:
-Los menores a 80%
-El primer valor igual o mayor a 80%
H o la: Completa en la macro los nombres de las hojas origen y destino; y también las columnas origen y destino, en esta parte de la macro.
Set h1 = Sheets("Hoja1") 'hoja con datos
Set h2 = Sheets("Hoja2") 'hoja destino
col1 = "A" 'columna con las actividades
col2 = "A" 'columna destinoTe anexo la macro.
Sub Copiar()
'Por.Dante Amor
Set h1 = Sheets("Hoja1") 'hoja con datos
Set h2 = Sheets("Hoja2") 'hoja destino
col1 = "A" 'columna con las actividades
col2 = "A" 'columna destino
'
wmin = 9999
For i = 2 To h1.Range(col1 & Rows.Count).End(xlUp).Row
u = h2.Range(col2 & Rows.Count).End(xlUp).Row + 1
valor = h1.Cells(i, Columns(col1).Column + 1)
Select Case valor
Case Is < 0.8
h1.Cells(i, col1).Interior.ColorIndex = 16
h2.Cells(u, col2) = h1.Cells(i, col1)
h2.Cells(u, Columns(col2).Column + 1) = h1.Cells(i, Columns(col1).Column + 1)
Case Is >= 0.8
If valor < wmin Then
fila = i
wmin = valor
End If
End Select
Next
If wmin <> 9999 Then
h1.Cells(fila, col1).Interior.ColorIndex = 16
u = h2.Range(col2 & Rows.Count).End(xlUp).Row + 1
h2.Cells(u, col2) = h1.Cells(fila, col1)
h2.Cells(u, Columns(col2).Column + 1) = h1.Cells(fila, Columns(col1).Column + 1)
End If
MsgBox "fin"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Hola gracias por tu aporte dejo los rangos si se puede acomodar a ellos please; al momento de copiar tambien esta copiando los porcentajes, solo debe copiar las actividades...
Si se puede que queden en negrita las actividades seleccionadas
Este el rango de las actividades: E8:E23 / Rango de las frecuencias: H8:H23
Te anexo la macro actualizada
Sub Copiar()
'Por.Dante Amor
Set h1 = Sheets("Hoja1") 'hoja con datos
Set h2 = Sheets("Hoja2") 'hoja destino
col1 = "E" 'columna con las actividades
col2 = "A" 'columna destino
'
wmin = 9999
For i = 8 To 23 'h1.Range(col1 & Rows.Count).End(xlUp).Row
u = h2.Range(col2 & Rows.Count).End(xlUp).Row + 1
valor = h1.Cells(i, Columns(col1).Column + 3)
Select Case valor
Case Is < 0.8
h1.Cells(i, col1).Font.Bold = True
h2.Cells(u, col2) = h1.Cells(i, col1)
'h2.Cells(u, Columns(col2).Column + 1) = h1.Cells(i, Columns(col1).Column + 1)
Case Is >= 0.8
If valor < wmin Then
fila = i
wmin = valor
End If
End Select
Next
If wmin <> 9999 Then
h1.Cells(fila, col1).Font.Bold = True
u = h2.Range(col2 & Rows.Count).End(xlUp).Row + 1
h2.Cells(u, col2) = h1.Cells(fila, col1)
'h2.Cells(u, Columns(col2).Column + 1) = h1.Cells(fila, Columns(col1).Column + 1)
End If
MsgBox "fin"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
