cut, paste, blank cell....

[rakietu]

RAW DATA:
http://img543.imageshack.us/img543/3753/rawdata.jpg

NEED DATA:
http://img525.imageshack.us/img525/5989/needdata.jpg

separate sign: $$$$

i have problem with data with empty cells (no telephone) or www.. to save empty space in next sheet
[vba]Sub szkajsigna()
Dim s As String, s2 As String, b As String, x As String


Dim Rng As Range, rCell As Range, signCounter As Integer
Set Rng = Range("A1:A500")
signCounter = rowCounter + 1


x = 1
For Z = 1 To 5
s = Cells.Find(What:="$$$$", After:=Cells(x, 1), LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlDown, MatchCase:= _
False, SearchFormat:=False).Row


s2 = Cells.Find(What:="$$$$", After:=Cells(s, 1), LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlDown, MatchCase:= _
False, SearchFormat:=False).Row
' MsgBox ("s=" & s & ", s2= " & s2)

x = s2 + 1

Set Rng = Range("A" & s, "A" & s2)
For i = s To s2
For Each rCell In Rng.Cells
If InStr(Cells(1 + i, 1).Value, "tel.") Then Sheets("Delay Duration").Range("B" & Rows.Count).End(xlUp).Offset(1) = rCell.Offset(0, 0)
' If InStr(rCell.Value, "www") Then Sheets("Delay Duration").Range("D" & Rows.Count).End(xlUp).Offset(1) = rCell.Offset(0, 0)
'If InStr(rCell.Value, "e-mail") Then Sheets("Delay Duration").Range("C" & Rows.Count).End(xlUp).Offset(1) = rCell.Offset(0, 0)


Next rCell
Next i
Next Z
End Sub



[/vba]

[sassora]

Is the raw data consistent? i.e. the same number of rows between each $$$$

If so you may want to use something like:

[VBA]Sub TransferList()

Dim intRawFirstRow As Integer, intRawFirstColumn As Integer, intNumberOfRawRows As Integer
Dim intInsertRow As Integer, intFieldsPerRecord As Integer, intFieldsTransferred As Integer, intRowCount As Integer

intRawFirstRow = 1
intRawFirstColumn = 1
intNumberOfRawRows = Sheets("Sheet1").Cells(intRawFirstRow, intRawFirstColumn).CurrentRegion.Rows.Count

intFieldsPerRecord = 11
intInsertRow = Sheets("Delay Duration").Cells(Rows.Count, 2).End(xlUp).Offset(1).Row
intFieldsTransferred = 0


Do While intFieldsTransferred <= intNumberOfRawRows

For intRowCount = 1 To intFieldsPerRecord

Sheets("Delay Duration").Cells(intInsertRow, 1 + intRowCount) = _
Sheets("Sheet1").Cells(intRawFirstRow + intFieldsTransferred, 1)

intFieldsTransferred = intFieldsTransferred + 1

Next intRowCount

intInsertRow = intInsertRow + 1

Loop

End Sub[/VBA]