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 .