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%

1 respuesta

Respuesta
2

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 destino

Te 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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas