Help with Vba script

[sbsite]

I tried to write a script for my problem - but the runing time is huge
the question is in the attached xls file

[mdmackillop]

Can you post your script?

[Bob Phillips]

[vba]

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim StartRow As Long
Dim EndRow As Long
Dim NumRows As Long
Dim NumUnique As Long

With ActiveSheet

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
EndRow = LastRow
For i = LastRow To 2 Step -1

If .Cells(i, TEST_COLUMN).Value = "xxxx" Then

EndRow = i
ElseIf .Cells(i, TEST_COLUMN).Value <> .Cells(i - 1, TEST_COLUMN).Value Then

StartRow = i
NumRows = EndRow - StartRow + 1
NumUnique = .Evaluate("SUMPRODUCT((B" & StartRow & ":B" & EndRow & " <>"""")/" & _
"COUNTIF(B" & StartRow & ":B" & EndRow & ",B" & StartRow & ":B" & EndRow & "&""""))")

If NumUnique > 1 Then

Worksheets("Sheet2").Range("A1").Resize(NumRows).Insert
.Rows(StartRow).Resize(NumRows).Cut Worksheets("Sheet2").Range("A1")
End If
End If
Next i
End With

End Sub
[/vba]

[mdmackillop]

[VBA]Option Explicit

Sub Macro2()
Dim Rng As Range, cel As Range
Dim sh As Worksheet
Dim i As Long

Set sh = Sheets(2)
Set Rng = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
Rng.Offset(, 5).FormulaR1C1 = "=RC[-5]&RC[-4]"
Cells(1, 6) = "List"
Rng.Offset(, 5).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheets(1).Range("E1"), Unique:=True
Columns("F:F").ClearContents

Set Rng = Range(Cells(1, 5), Cells(1, 5).End(xlDown))
With ActiveSheet.Sort
.SetRange Rng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For Each cel In Rng
If IsNumeric(cel) Then
i = i + 1
sh.Cells(i, 1) = Left(cel, 2)
sh.Cells(i, 2) = Right(cel, Len(cel) - 2)
End If
Next
Columns("E:E").ClearContents
Sheets("Sheet1").Select
Range("D34").Select
End Sub
[/VBA]