Macro to Insert an Equals Formula

[norts55]

I need a macro that will insert an equals formula into a group of selected cells.

I have a macro (shown below) that finds a unique font color within my current selection. I need to add a function to the end of this macro. After the font color is found and those cells are then selected, I need a dialog box to pop up and ask “Select a Cell that These Cells Should Equal”, after that cell is selected, I need an equals formula (equaling that cell) inserted into the cells that have this font color.

I hope this makes sense. If not, please let me know if I need to give more information. Thank you in advance.

Sub Macro4()'
' Macro4 Macro
'


'
    Dim rngFound As Range, rngAll As Range
    Dim strFirst As String, lColor As Variant, arrColors As Variant
        
    arrColors = Array(RGB(194, 5, 5))
    With Selection
        For Each lColor In arrColors
            With Application.FindFormat
                .Clear
                .Font.Color = lColor        'Search for font color
            End With
            On Error Resume Next
            Set rngFound = .Find("", .Cells(.Cells.Count), SearchFormat:=True)
            On Error GoTo 0
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                Do
                    If rngAll Is Nothing Then
                        Set rngAll = rngFound
                    Else
                        Set rngAll = Union(rngAll, rngFound)
                    End If
                    Set rngFound = .Find("", rngFound, SearchFormat:=True)
                Loop While rngFound.Address <> strFirst
            End If
        Next lColor
    End With
    
    If Not rngAll Is Nothing Then
        rngAll.Select
        Set rngAll = Nothing
        Set rngFound = Nothing
        strFirst = vbNullString
    Else
        MsgBox "No cells found with any font color "
    End If
    Application.FindFormat.Clear
    
End Sub

 

[D3allamerican07]

Why not just add something like this at the bottom of the macro instead of calling a function.

Sub Macro4()

    Dim rngFound As Range, rngAll As Range
    Dim strFirst As String, lColor As Variant, arrColors As Variant
        
    arrColors = Array(RGB(194, 5, 5))
    With Selection
        For Each lColor In arrColors
            With Application.FindFormat
                .Clear
                .Font.Color = lColor 'Search for font color
            End With
            On Error Resume Next
            Set rngFound = .Find("", .Cells(.Cells.Count), SearchFormat:=True)
            On Error GoTo 0
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                Do
                    If rngAll Is Nothing Then
                        Set rngAll = rngFound
                    Else
                        Set rngAll = Union(rngAll, rngFound)
                    End If
                    Set rngFound = .Find("", rngFound, SearchFormat:=True)
                Loop While rngFound.Address <> strFirst
            End If
        Next lColor
    End With
    
    If Not rngAll Is Nothing Then
        rngAll.Select
        Set rngAll = Nothing
        Set rngFound = Nothing
        strFirst = vbNullString
        
[B][COLOR=#ff0000]            Set Rng = Application.InputBox("Select a cell", "Obtain Range Object", Type:=8)
        
            For Each cell In Selection
                cell.Formula = "=" & Rng.Address & ""
            Next cell[/COLOR][/B]
    
    Else
        MsgBox "No cells found with any font color "
    End If
    
    Application.FindFormat.Clear
    
End Sub

 

[norts55]

Thank you very much for the response. This works just like I described but I now see it is not exactly what I need.

Is there a way to add a line of code at the very end of this macro to go to the previous selection? Or, is there a way to have this macro select the cell that will be part of the formula but not actually override the current selection? I am adding this as part of a larger routine and I need that previous selection returned or kept for modifications to other cells with unique font colors.

If you feel this deserves a new thread just let me know. Thanks!

 

[D3allamerican07]

If I'm understanding this correctly, you want to, at the end of the macro, select the cells that were selected when the code is run? If so, it is done simply by adding the highlighted lines.

Sub Macro4()

    Dim rngFound As Range, rngAll As Range
    Dim strFirst As String, lColor As Variant, arrColors As Variant
    Dim selectRng As Range
    
    arrColors = Array(RGB(194, 5, 5))
    With Selection
[B][COLOR=#ff0000]        Set selectRng = Selection[/COLOR][/B]
        For Each lColor In arrColors
            With Application.FindFormat
                .Clear
                .Font.Color = lColor 'Search for font color
            End With
            On Error Resume Next
            Set rngFound = .Find("", .Cells(.Cells.Count), SearchFormat:=True)
            On Error GoTo 0
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                Do
                    If rngAll Is Nothing Then
                        Set rngAll = rngFound
                    Else
                        Set rngAll = Union(rngAll, rngFound)
                    End If
                    Set rngFound = .Find("", rngFound, SearchFormat:=True)
                Loop While rngFound.Address <> strFirst
            End If
        Next lColor
    End With
    
    If Not rngAll Is Nothing Then
        rngAll.Select
        Set rngAll = Nothing
        Set rngFound = Nothing
        strFirst = vbNullString
        
            Set Rng = Application.InputBox("Select a cell", "Obtain Range Object", Type:=8)
        
            For Each cell In Selection
                cell.Formula = "=" & Rng.Address & ""
            Next cell
    
    Else
        MsgBox "No cells found with any font color "
    End If
    
[B][COLOR=#ff0000]    selectRng.Select[/COLOR][/B]
    
    Application.FindFormat.Clear
    
End Sub

Let me know if this is what you wanted.

 

[norts55]

Thank you Bill. That was the line(s) of code I needed. I had to place this in a different location of my larger macro to get it to work, but once I found the correct location, it works perfectly. Thanks again.

 

[D3allamerican07]

Awesome, glad I could help!