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.

Loop not working!!
 

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" wrote in message
...
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.

Loop not working!!
 

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" wrote in message
...
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.