Loop not working!!

Can anyone help with the following.....I'm using Excel 2000, on Win2k
I've got 55000 row of data to sort, here's an example;

Analysis Code Date Product Units
1A1 1-Nov-04 P02545 29
1A2 1-Nov-04 P02421 4
1Q2 1-Nov-04 P03400 11
1B 1-Nov-04 P09501 -1

Where Analysis Code is in Column A, Date in column B etc......

I need the macro to find each Analysis Code, copy the entire row, and paste
it to a different worksheet in the workbook. So all the A1A into sheet 'A1A',
1A2 into Sheet '1A2' etc..........

I've written the following code, and it only works for the first With, E.G.
it finds all '1A2', but the activates sheet '1A5' then stops without fining
anything else!! I need to to loop through each analysis code (there are about
60).
Sub datasort()
Dim R As Integer, C As Integer
R = 1
C = 1
Worksheets("Christmas0405").Select
Range("A1").Select
With Worksheets("Christmas0405").Range("a1:d65000")
Set D = .Find("1A2")
If Not D Is Nothing Then
firstAddress = D.Address
Do
D.EntireRow.Copy
Worksheets("1A2").Activate
Range("a1").Select
Do While Cells(R, C) <> ""
Cells(R, C).Activate
R = R + 1
If Cells(R, C) = "" Then
C = 1
Cells(R, C).PasteSpecial Paste:=xlValues
Exit Do
End If
If R >= 64536 Then
MsgBox ("No blank rows")
Exit Do
End If
Loop
Set D = .FindNext(D)
Loop While Not D Is Nothing And D.Address <> firstAddress
End If
End With
With Worksheets("Christmas0405").Range("a1:d65000")
Set D = .Find("1A5")
If Not D Is Nothing Then
firstAddress = D.Address
Do
D.EntireRow.Copy
Worksheets("1A5").Activate
Range("a1").Select
Do While Cells(R, C) <> ""
Cells(R, C).Activate
R = R + 1
If Cells(R, C) = "" Then
C = 1
Cells(R, C).PasteSpecial Paste:=xlValues
Exit Do
End If
If R >= 64536 Then
MsgBox ("No blank rows")
Exit Do
End If
Loop
Set D = .FindNext(D)
Loop While Not D Is Nothing And D.Address <> firstAddress
End If
End With
End Sub

Many thanks in advance of your help!!

Simon.

See Ron De Bruin's site where he has written a macro to do most of this:

http://www.rondebruin.nl/copy5.htm

--
Regards,
Tom Ogilvy

"Simon" <[email protected]> wrote in message
news:[email protected]...
> Can anyone help with the following.....I'm using Excel 2000, on Win2k
> I've got 55000 row of data to sort, here's an example;
>
> Analysis Code Date Product Units
> 1A1 1-Nov-04 P02545 29
> 1A2 1-Nov-04 P02421 4
> 1Q2 1-Nov-04 P03400 11
> 1B 1-Nov-04 P09501 -1
>
> Where Analysis Code is in Column A, Date in column B etc......
>
> I need the macro to find each Analysis Code, copy the entire row, and
paste
> it to a different worksheet in the workbook. So all the A1A into sheet
'A1A',
> 1A2 into Sheet '1A2' etc..........
>
> I've written the following code, and it only works for the first With,
E.G.
> it finds all '1A2', but the activates sheet '1A5' then stops without
fining
> anything else!! I need to to loop through each analysis code (there are
about
> 60).
> Sub datasort()
> Dim R As Integer, C As Integer
> R = 1
> C = 1
> Worksheets("Christmas0405").Select
> Range("A1").Select
> With Worksheets("Christmas0405").Range("a1:d65000")
> Set D = .Find("1A2")
> If Not D Is Nothing Then
> firstAddress = D.Address
> Do
> D.EntireRow.Copy
> Worksheets("1A2").Activate
> Range("a1").Select
> Do While Cells(R, C) <> ""
> Cells(R, C).Activate
> R = R + 1
> If Cells(R, C) = "" Then
> C = 1
> Cells(R, C).PasteSpecial Paste:=xlValues
> Exit Do
> End If
> If R >= 64536 Then
> MsgBox ("No blank rows")
> Exit Do
> End If
> Loop
> Set D = .FindNext(D)
> Loop While Not D Is Nothing And D.Address <> firstAddress
> End If
> End With
> With Worksheets("Christmas0405").Range("a1:d65000")
> Set D = .Find("1A5")
> If Not D Is Nothing Then
> firstAddress = D.Address
> Do
> D.EntireRow.Copy
> Worksheets("1A5").Activate
> Range("a1").Select
> Do While Cells(R, C) <> ""
> Cells(R, C).Activate
> R = R + 1
> If Cells(R, C) = "" Then
> C = 1
> Cells(R, C).PasteSpecial Paste:=xlValues
> Exit Do
> End If
> If R >= 64536 Then
> MsgBox ("No blank rows")
> Exit Do
> End If
> Loop
> Set D = .FindNext(D)
> Loop While Not D Is Nothing And D.Address <> firstAddress
> End If
> End With
> End Sub
>
> Many thanks in advance of your help!!
>
> Simon.

Hi, Tom. Good to see you. I sicnerely would appreciate some of your
expertise on a post I made four spots above this one, "formula help". This
is an issue I just can't get resolved. You have always been very helpful, I
hope you can help this time. Thanks in advance.

"Tom Ogilvy" wrote:

> See Ron De Bruin's site where he has written a macro to do most of this:
>
> http://www.rondebruin.nl/copy5.htm
>
> --
> Regards,
> Tom Ogilvy
>
> "Simon" <[email protected]> wrote in message
> news:[email protected]...
> > Can anyone help with the following.....I'm using Excel 2000, on Win2k
> > I've got 55000 row of data to sort, here's an example;
> >
> > Analysis Code Date Product Units
> > 1A1 1-Nov-04 P02545 29
> > 1A2 1-Nov-04 P02421 4
> > 1Q2 1-Nov-04 P03400 11
> > 1B 1-Nov-04 P09501 -1
> >
> > Where Analysis Code is in Column A, Date in column B etc......
> >
> > I need the macro to find each Analysis Code, copy the entire row, and
> paste
> > it to a different worksheet in the workbook. So all the A1A into sheet
> 'A1A',
> > 1A2 into Sheet '1A2' etc..........
> >
> > I've written the following code, and it only works for the first With,
> E.G.
> > it finds all '1A2', but the activates sheet '1A5' then stops without
> fining
> > anything else!! I need to to loop through each analysis code (there are
> about
> > 60).
> > Sub datasort()
> > Dim R As Integer, C As Integer
> > R = 1
> > C = 1
> > Worksheets("Christmas0405").Select
> > Range("A1").Select
> > With Worksheets("Christmas0405").Range("a1:d65000")
> > Set D = .Find("1A2")
> > If Not D Is Nothing Then
> > firstAddress = D.Address
> > Do
> > D.EntireRow.Copy
> > Worksheets("1A2").Activate
> > Range("a1").Select
> > Do While Cells(R, C) <> ""
> > Cells(R, C).Activate
> > R = R + 1
> > If Cells(R, C) = "" Then
> > C = 1
> > Cells(R, C).PasteSpecial Paste:=xlValues
> > Exit Do
> > End If
> > If R >= 64536 Then
> > MsgBox ("No blank rows")
> > Exit Do
> > End If
> > Loop
> > Set D = .FindNext(D)
> > Loop While Not D Is Nothing And D.Address <> firstAddress
> > End If
> > End With
> > With Worksheets("Christmas0405").Range("a1:d65000")
> > Set D = .Find("1A5")
> > If Not D Is Nothing Then
> > firstAddress = D.Address
> > Do
> > D.EntireRow.Copy
> > Worksheets("1A5").Activate
> > Range("a1").Select
> > Do While Cells(R, C) <> ""
> > Cells(R, C).Activate
> > R = R + 1
> > If Cells(R, C) = "" Then
> > C = 1
> > Cells(R, C).PasteSpecial Paste:=xlValues
> > Exit Do
> > End If
> > If R >= 64536 Then
> > MsgBox ("No blank rows")
> > Exit Do
> > End If
> > Loop
> > Set D = .FindNext(D)
> > Loop While Not D Is Nothing And D.Address <> firstAddress
> > End If
> > End With
> > End Sub
> >
> > Many thanks in advance of your help!!
> >
> > Simon.
>
>
>