Requiero código para cambiar de color una linea que crea un macro

Tengo una macro que me crea líneas azules, lo único que tengo que hacer es cambiar el color de las líneas a negro, para Dante Amor.

El código es

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("L8")) Is Nothing Then
'Borrando líneas anteriores
For Each s In ActiveSheet.Shapes
If s.Name = "milineacreada" Then
s.Delete
End If
Next
'
Set r = Range("B17:D49, G17:I49")
Set B = r.Find("CALIF", lookat:=xlWhole)
If Not B Is Nothing Then
celda = B.Address
Do
'Creando líneas
If Cells(B.Row + 1, B.Column) = "" Then
Set r1 = Cells(B.Row + 1, B.Column)
fila = B.Row + 1
Do While Cells(fila, B.Column).HasFormula
fila = fila + 1
Loop
Set r2 = Cells(fila, B.Column + 3)
Set linea = ActiveSheet.Shapes.AddLine(r1.Left, r1.Top, r2.Left, r2.Top)
linea.Name = "milineacreada"
End If
Set B = r.FindNext(B)
Loop While Not B Is Nothing And B.Address <> celda
End If
End If
End Sub

Respuesta
2

H o l a : Hay que agregar esta línea

linea.Line.ForeColor.RGB = RGB(0, 0, 0)

Te anexo la macro actualizada

Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("L8")) Is Nothing Then
        'Borrando líneas anteriores
        For Each s In ActiveSheet.Shapes
            If s.Name = "milineacreada" Then
                s.Delete
            End If
        Next
        '
        Set r = Range("B17:D49, G17:I49")
        Set B = r.Find("CALIF", lookat:=xlWhole)
        If Not B Is Nothing Then
            celda = B.Address
            Do
                'Creando líneas
                If Cells(B.Row + 1, B.Column) = "" Then
                    Set r1 = Cells(B.Row + 1, B.Column)
                    fila = B.Row + 1
                    Do While Cells(fila, B.Column).HasFormula
                        fila = fila + 1
                    Loop
                    Set r2 = Cells(fila, B.Column + 3)
                    Set linea = ActiveSheet.Shapes.AddLine(r1.Left, r1.Top, r2.Left, r2.Top)
                    linea.Name = "milineacreada"
                    linea.Line.ForeColor.RGB = RGB(0, 0, 0)
                End If
                Set B = r.FindNext(B)
            Loop While Not B Is Nothing And B.Address <> celda
        End If
    End If
End Sub

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
La pregunta no admite más respuestas

Más respuestas relacionadas