Cell with multiple lines of data , delete lines without # into one line

[parscon]

I have about 58000 cells, each with about differenet separate lines of text. Each line of texts has been entered using the ALT+ENTER method.

Can anybody suggest a way, VBA method to delete the line without charcter # and convert each of these cells into one line, with # between each line

Example: Current Cell 1:

About
11173
Horse#Car
Apple
Orange#Apple#Pizza
Dog
2278561#1231


Need: Cell 1:

Horse#Car#Orange#Apple#Pizza#2278561#1231

[Kenneth Hobs]

Change ActiveSheet.UsedRange to suit.

Sub Main()  
  Dim a, ea, b, s$, c As Range, i As Integer, j As Integer
  For Each c In ActiveSheet.UsedRange
    a = Split(c, vbLf)
    ReDim b(0 To UBound(a))
    j = -1
    For i = 0 To UBound(a)
      If InStr(a(i), "#") > 0 Then
        j = j + 1
        b(j) = a(i)
      End If
    Next i
    If j > -1 Then
      ReDim Preserve b(j)
      c.Value = Join(b, "#")
    End If
  Next c
End Sub

[MINCUS1308]

Sub test()
     Dim MyStr As String
     MyStr = Sheet1.Cells(1, 1).Text
     Sheet1.Cells(1, 1).Value = Replace(MyStr, Chr(10), " ")
End Sub

[MINCUS1308]

dang Kenneth, beat me by a second and with a much better answer

[parscon]

Really appreciate for your help Kenneth Hobs .

[Kenneth Hobs]

Glad it helps. I didn't add any speedup options like screen updating, calculation to manual, nor disable events. I can do so if needed. I show how in the KB.

It happens to me too Mincus1308...

[parscon]

Dear Keeneth , if i have blank row between data it does not work . is it possible also add speedup options , is it possible ,
Show me Run-time error '9' Subscript out of range error and loop does not work .
Thank you again

[Kenneth Hobs]

Sub Main()  
  Dim a, ea, b, s$, c As Range, i As Integer, j As Integer
  Dim calc As Integer
  On Error Resume Next
    
  'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
  With Application
    calc = .Calculation
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
  End With


  For Each c In ActiveSheet.UsedRange
    a = Split(c, vbLf)
    ReDim b(0 To UBound(a))
    j = -1
    For i = 0 To UBound(a)
      If InStr(a(i), "#") > 0 Then
        j = j + 1
        b(j) = a(i)
      End If
    Next i
    If j > -1 Then
      ReDim Preserve b(j)
      c.Value = Join(b, "#")
    End If
  Next c
  
  With Application
    .Calculation = calc
    .EnableEvents = True
    .ScreenUpdating = True
    .CutCopyMode = False
  End With
End Sub

[parscon]

Really it is working 100% and thank you . really thank you .