Here is a modification:
Sub ABC()
Dim tt As Single
Dim calc As Long
Dim rng As Range, rng1 As Range
tt = Timer
calc = Application.Calculation
Application.Calculation = xlManual
Set rng = Intersect(ActiveSheet.UsedRange.EntireRow, _
ActiveSheet.Columns(10))
For Each cell In rng
cell.Formula = "=if(Countif($G$1:$G$5000,G" & cell.Row & ")>1,na(),"""")"
ActiveSheet.Calculate
cell.Formula = cell.Value
If cell.Row Mod 10 = 0 Then Application.StatusBar = cell.Row
Next
On Error Resume Next
Set rng1 = rng.SpecialCells(xlConstants, xlErrors)
On Error GoTo 0
If Not rng1 Is Nothing Then
rng1.EntireRow.Copy Worksheets("Sheet2").Range("A1")
rng1.EntireRow.Delete
Worksheets("Sheet2").Columns(10).ClearContents
End If
ActiveSheet.Columns(10).ClearContents
Application.Calculation = calc
Application.StatusBar = False
Debug.Print Timer - tt
End Sub
took about 10 seconds for me with 3500 rows.
--
Regards,
Tom Ogilvy
"fpd833" <(E-Mail Removed)> wrote in message
news:646F994C-D9E1-4A2D-8766-(E-Mail Removed)...
> I'm running through about 3000 rows of data. When I run the macro Excel
> tells
> me "Calaculating Cells 100%".....it does this twice but hangs at the
> second
> 100%. I have left it running for 30 minutes.....
>
> Thanks Tom!
>
> "Tom Ogilvy" wrote:
>
>> Sub ABC()
>> Dim rng As Range, rng1 As Range
>> Set rng = Intersect(ActiveSheet.UsedRange.EntireRow, _
>> ActiveSheet.Columns(10))
>> rng.Formula = "=if(Countif($G:$G,G1)>1,na(),"""")"
>> On Error Resume Next
>> Set rng1 = rng.SpecialCells(xlFormulas, xlErrors)
>> On Error GoTo 0
>> If Not rng1 Is Nothing Then
>> rng1.EntireRow.Copy Worksheets("Sheet2").Range("A1")
>> rng1.EntireRow.Delete
>> Worksheets("Sheet2").Columns(10).ClearContents
>> End If
>> ActiveSheet.Columns(10).ClearContents
>> End Sub
>>
>> code worked fine for me.
>>
>> Tested in xl2003
>>
>> How many rows are you trying to process.
>>
>> --
>> Regards,
>> Tom Ogilvy
>>
>>
>> "fpd833" wrote:
>>
>> > Thanks Tom....that change makes sense! However this routine causes
>> > Excel to
>> > stop responding. Any ideas?
>> >
>> > "Tom Ogilvy" wrote:
>> >
>> > > Column G
>> > > A
>> > > A '<== duplicate
>> > > A '<== duplicate
>> > >
>> > > Is my interpretation of duplicate records and the code does that. If
>> > > what
>> > > you describe now is what you actually want, the modification is
>> > > simple:
>> > >
>> > > Sub ABC()
>> > > Dim rng As Range, rng1 As Range
>> > > Set rng = Intersect(ActiveSheet.UsedRange.EntireRow, _
>> > > ActiveSheet.Columns(10))
>> > > rng.Formula = "=if(Countif($G:G,G1)>1,na(),"""")"
>> > > On Error Resume Next
>> > > Set rng1 = rng.SpecialCells(xlFormulas, xlErrors)
>> > > On Error GoTo 0
>> > > If Not rng1 Is Nothing Then
>> > > rng1.EntireRow.Copy Worksheets("Sheet2").Range("A1")
>> > > rng1.EntireRow.Delete
>> > > Worksheets("Sheet2").Columns(10).ClearContents
>> > > End If
>> > > ActiveSheet.Columns(10).ClearContents
>> > > End Sub
>> > >
>> > > --
>> > > Regards,
>> > > Tom Ogilvy
>> > >
>> > >
>> > > "fpd833" wrote:
>> > >
>> > > > Following up on a previous post.
>> > > >
>> > > > I have a list of data in columns A:I. I need to find all duplicate
>> > > > rows in
>> > > > the used range based on the data in col G, cut the all duplicates
>> > > > and paste
>> > > > into another worksheet in the workbook.
>> > > >
>> > > > Tom Ogilvy provided the following routine, but this leaves behind 1
>> > > > of the
>> > > > duplicate rows. Lets say I have 3 rows that have the same data in
>> > > > col G, is
>> > > > it possible to cut and past all 3 rows into the other sheet? Thanks
>> > > > in
>> > > > advance for any help you can provide.
>> > > >
>> > > > Thanks!
>> > > >
>> > > > Sub ABC()
>> > > > Dim rng As Range, rng1 As Range
>> > > > Set rng = Intersect(ActiveSheet.UsedRange.EntireRow, _
>> > > > ActiveSheet.Columns(10))
>> > > > rng.Formula = "=if(Countif($G$1:G1,G1)>1,na(),"""")"
>> > > > On Error Resume Next
>> > > > Set rng1 = rng.SpecialCells(xlFormulas, xlErrors)
>> > > > On Error GoTo 0
>> > > > If Not rng1 Is Nothing Then
>> > > > rng1.EntireRow.Copy Worksheets("Sheet2").Range("A1")
>> > > > rng1.EntireRow.Delete
>> > > > Worksheets("Sheet2").Columns(10).ClearContents
>> > > > End If
>> > > > ActiveSheet.Columns(10).ClearContents
>> > > > End Sub
>> > > >
>> > > >
|
Similar Threads
