How to find the cell with note and put them all into 1 cell with differnce line

Hi

sorry to say your sample sheet does not give a clear pic on what you want to do.
Hope you can do this using VLOOKUP & CONCATENATE functions.

if you can post a sample sheet with little more clarification on it, it would be help to sort out this urgently.

try

Sub test()
    Dim rng As Range, r As Range, txt As String
    Range("u14").ClearContents
    Set rng = Range("u15", Range("u" & Rows.Count).End(xlUp)).SpecialCells(2)
    If rng Is Nothing Then Exit Sub
    For Each r In rng
        txt = Join$(Array(txt, Join$(Array(r(, -18).Value, r.Value), ": ")), vbLf)
    Next
    Range("u14").Value = Mid$(txt, 2)
    Set rng = Nothing
End Sub

as an option, UDF

Function CombineText(r1 As Range, r2 As Range) As String
Dim x, y, i&, s$
x = r1.Value: y = r2.Value
If UBound(x) <> UBound(y) Then CombineText = "###": Exit Function
For i = 1 To UBound(y)
    If Len(y(i, 1)) Then s = s & vbCrLf & x(i, 1) & ": " & y(i, 1)
Next
If Len(s) Then CombineText = Mid(s, 3) Else CombineText = "###"
End Function

Private Sub CommandButton1_Click()
    'Below is working perfect but missing ***
    Dim rng1 As Range, r As Range, txt As String
    Range("u14").ClearContents
    Set rng1 = Range("u15", Range("u" & Rows.Count).End(xlUp)).SpecialCells(2)
    If rng1 Is Nothing Then Exit Sub
    For Each r In rng1
        txt = Join$(Array(txt, "***" & Join$(Array(r(, -18).Value, r.Value), ": ")), vbLf)
    Next
    Range("u14").Value = Mid$(txt, 2)
    Set rng1 = Nothing
End Sub

Hi Prashantha
Thank you for the reply and I will try to be more clear.

@Jindon
Thank you very much for the help. I have been able to get the 3 stars (***) at the beginning of each text line but cannot figure out how to put them at the end of each text line. Can you please help? Thank you.

@nilem
Thank you for your help. Can you teach me how to use your function?

Change

txt = Join$(Array(txt, Join$(Array(r(, -18).Value, r.Value), ": ")), vbLf)

to

txt = Join$(Array(txt, Join$(Array("***" & r(, -18).Value, Trim$(r.Value)), ": ") & "***"), vbLf)

Originally Posted by jindon

Change

txt = Join$(Array(txt, Join$(Array(r(, -18).Value, r.Value), ": ")), vbLf)

to

txt = Join$(Array(txt, Join$(Array("***" & r(, -18).Value, Trim$(r.Value)), ": ") & "***"), vbLf)

Hi Jindon,
The new code is perfect and thank you very much for your help. When I transfer to another sheet then all text merge together so how can i break them from ***Honda01: PartXXX******Honda01: PartYYY to

***Honda01: PartXXX***
***Honda02: PartYYY***

Regards,
tt3

Sorry, but I don't understand what you are asking.

Can you upload the file again?

Change to

Private Sub CommandButton1_Click()
    Dim rng As Range, r As Range, txt As String
    Range("u14").ClearContents
    On Error Resume Next
    Set rng = Range("u15", Range("u" & Rows.Count)).SpecialCells(2)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    For Each r In rng
        txt = Join$(Array(txt, Join$(Array("***" & r(, -18).Value, Trim$(r.Value)), ": ") & "***"), vbLf)
    Next
    Range("u14").Value = Mid$(txt, 2)
    Set rng = Nothing
End Sub

Originally Posted by jindon

Change to

Private Sub CommandButton1_Click()
    Dim rng As Range, r As Range, txt As String
    Range("u14").ClearContents
    On Error Resume Next
    Set rng = Range("u15", Range("u" & Rows.Count)).SpecialCells(2)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    For Each r In rng
        txt = Join$(Array(txt, Join$(Array("***" & r(, -18).Value, Trim$(r.Value)), ": ") & "***"), vbLf)
    Next
    Range("u14").Value = Mid$(txt, 2)
    Set rng = Nothing
End Sub

Hi jindon,
The above code is work perfect as I expected. Thank you very much for your time and help.

Best regards,
tt3