Macro Help! Maintaining font colours

[CDel]

Hi, I have a macro that prompts a user to select cells - these can be non adjacent - and paste them into a cell the user selects.
I found the macro somewhere online and it's great.

I am looking to add in font colour.
The cells being copied from are specific colours and I need to be able to maintain colour in the pasted cell.
Any help would be greatly appreciated! Thanks

Sub G()

    Dim strFinal$
    Dim cell As Range
    Dim rngSource As Range
    Dim rngArea As Range
    Dim rngTarget As Range

    Set rngSource = Application.InputBox("Select cells to merge", Type:=8)
    Set rngTarget = Application.InputBox("Select destination cell", Type:=8)
    For Each rngArea In rngSource
        For Each cell In rngArea
            strFinal = strFinal & cell.Value & " "
        Next
    Next
    strFinal = Left$(strFinal, Len(strFinal) - 1)
    rngTarget.Value = strFinal

End Sub

 

[JoeMo]

Assuming the cells selected to "merge" all have the same fill color:

Sub G()
    Dim strFinal$
    Dim cell As Range, cellColor As Long
    Dim rngSource As Range
    Dim rngArea As Range
    Dim rngTarget As Range

    Set rngSource = Application.InputBox("Select cells to merge", Type:=8)
    Set rngTarget = Application.InputBox("Select destination cell", Type:=8)
    cellColor = rngSource(1).Interior.Color
    For Each rngArea In rngSource
        For Each cell In rngArea
            strFinal = strFinal & cell.Value & " "
        Next
    Next
    strFinal = Left$(strFinal, Len(strFinal) - 1)
    With rngTarget
        .Value = strFinal
        .Interior.Color = cellColor
        .EntireColumn.AutoFit
    End With
End Sub

 

[Rick Rothstein]

Give this macro a try...

Sub CombineMultipleCellsIntoOneCellKeepColors()

  Dim strFinal As String
  Dim rngSource As Range, rngTarget As Range, Cell As Range
  
  Set rngSource = Application.InputBox("Select cells to merge", Type:=8)
  Set rngTarget = Application.InputBox("Select destination cell", Type:=8)
  
  For Each Cell In rngSource
    With rngTarget.Characters(Len(rngTarget))
      .Text = IIf(Len(rngTarget.Value), " ", "") & Cell.Value
      .Font.Color = Cell.Font.Color
    End With
  Next
  
End Sub

 

[CDel]

Give this macro a try...

Sub CombineMultipleCellsIntoOneCellKeepColors()

  Dim strFinal As String
  Dim rngSource As Range, rngTarget As Range, Cell As Range
 
  Set rngSource = Application.InputBox("Select cells to merge", Type:=8)
  Set rngTarget = Application.InputBox("Select destination cell", Type:=8)
 
  For Each Cell In rngSource
    With rngTarget.Characters(Len(rngTarget))
      .Text = IIf(Len(rngTarget.Value), " ", "") & Cell.Value
      .Font.Color = Cell.Font.Color
    End With
  Next
 
End Sub

Hi, Thank you very much for your response.

I have just tried this - for some reason, the last character in the first cell I choose to merge is is being cut off? I've attached an image to show what I mean. any ideas why this is? Otherwise it is brilliant!

 

[CDel]

Give this macro a try...

Sub CombineMultipleCellsIntoOneCellKeepColors()

  Dim strFinal As String
  Dim rngSource As Range, rngTarget As Range, Cell As Range
 
  Set rngSource = Application.InputBox("Select cells to merge", Type:=8)
  Set rngTarget = Application.InputBox("Select destination cell", Type:=8)
 
  For Each Cell In rngSource
    With rngTarget.Characters(Len(rngTarget))
      .Text = IIf(Len(rngTarget.Value), " ", "") & Cell.Value
      .Font.Color = Cell.Font.Color
    End With
  Next
 
End
[/QUOTE]

Assuming the cells selected to "merge" all have the same fill color:

Sub G()
    Dim strFinal$
    Dim cell As Range, cellColor As Long
    Dim rngSource As Range
    Dim rngArea As Range
    Dim rngTarget As Range

    Set rngSource = Application.InputBox("Select cells to merge", Type:=8)
    Set rngTarget = Application.InputBox("Select destination cell", Type:=8)
    cellColor = rngSource(1).Interior.Color
    For Each rngArea In rngSource
        For Each cell In rngArea
            strFinal = strFinal & cell.Value & " "
        Next
    Next
    strFinal = Left$(strFinal, Len(strFinal) - 1)
    With rngTarget
        .Value = strFinal
        .Interior.Color = cellColor
        .EntireColumn.AutoFit
    End With
End Sub

Managed to get it working with @Rick Rothstein's Macro - but thank you for taking the time to answer - I really appreciate it!