Hi Nila,

Am Sat, 7 Jun 2014 08:06:59 +0200 schrieb Claus Busch:

try:
here is another suggestion that is easier to read and understand:

Sub Sort()
Dim cRet As Range, rngS As Range
Dim LRow As Long, myCnt As Long, First As Long
Dim FirstAddress As String
Dim ArrIn As Variant

'Modify source sheet name
With Sheets("Test")
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
'Set search range
Set rngS = .Range("A1:A" & LRow)
End With

'Modify target sheet name
With Sheets("Sheet1")
Set cRet = rngS.Find("##RETENTION_TIME", LookIn:=xlValues)
If Not cRet Is Nothing Then
FirstAddress = cRet.Address
Do
'Count of NPoints
myCnt = Trim(Mid(cRet.Offset(2, 0), _
InStr(cRet.Offset(2, 0), "=") + 1, 99))
'first empty row
First = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
First = IIf(First = 2, 1, First)
.Cells(First, 1).Resize(rowsize:=myCnt) = _
Trim(Mid(cRet, InStr(cRet, "=") + 1, 99))
ArrIn = cRet.Offset(4, 0).Resize(rowsize:=myCnt)
.Cells(First, 2).Resize(rowsize:=myCnt) = ArrIn
Set cRet = rngS.FindNext(cRet)
Loop While Not cRet Is Nothing And cRet.Address < FirstAddress
End If
.Columns("B").TextToColumns Destination:=Range("B1"),
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Comma:=True, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
End With
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional