copy macro help

[Guest]

Anyhelp would be greatly appreciated..

I need a macro that will copy all the rows on a spreadsheet and send them to
the appropriate sheets based on the value in the B column in the row. For
example, B5 has value as "RES" so i want that row sent to the next available
row on the RES spread sheet. If it was "BOB" then i would want it sent to the
bob spreadsheet. Could someone please help me with this? Thank you!

I apolgize if this is a duplicate post. Ive tried to post several times and
hours later it hasn't showed up..

Thanks!

 

[Guest]

Michael try this:
Sub Macro1()
ThisSheet = ActiveSheet.Name
Range("B1").Select
ActiveCell.Offset(1, 0).Range("A1").Select
Do Until ActiveCell.Value = ""
ToSheet = ActiveCell.Value
ActiveCell.EntireRow.Copy
Sheets(ToSheet).Select
ActiveSheet.Paste
Sheets(ThisSheet).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Loop
Application.CutCopyMode = False
End Sub

Thanks,

 

[Guest]

Sorry forgot to put it in the right place:
Sub Macro1()
ThisSheet = ActiveSheet.Name
Range("B1").Select
ActiveCell.Offset(1, 0).Range("A1").Select
Do Until ActiveCell.Value = ""
ToSheet = ActiveCell.Value
ActiveCell.EntireRow.Copy
Sheets(ToSheet).Select
Range("A1").Select
Selection.End(xlDown).Select
If ActiveCell.Row = 65536 Then
Range("A2").Select
Else
ActiveCell.Offset(1, 0).Range("A1").Select
End If
ActiveSheet.Paste
Sheets(ThisSheet).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Loop
Application.CutCopyMode = False
End Sub

 

[Guest]

Sorry forgot to put it in the right place.
Sub Macro1()
ThisSheet = ActiveSheet.Name
Range("B1").Select
ActiveCell.Offset(1, 0).Range("A1").Select
Do Until ActiveCell.Value = ""
ToSheet = ActiveCell.Value
ActiveCell.EntireRow.Copy
Sheets(ToSheet).Select
Range("A1").Select
Selection.End(xlDown).Select
If ActiveCell.Row = 65536 Then
Range("A2").Select
Else
ActiveCell.Offset(1, 0).Range("A1").Select
End If
ActiveSheet.Paste
Sheets(ThisSheet).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Loop
Application.CutCopyMode = False
End Sub

 

[Guest]

Sub Macro1()
ThisSheet = ActiveSheet.Name
Range("B1").Select
ActiveCell.Offset(1, 0).Range("A1").Select
Do Until ActiveCell.Value = ""
ToSheet = ActiveCell.Value
ActiveCell.EntireRow.Copy
Sheets(ToSheet).Select
Range("A1").Select
Selection.End(xlDown).Select
If ActiveCell.Row = 65536 Then
Range("A2").Select
Else
ActiveCell.Offset(1, 0).Range("A1").Select
End If
ActiveSheet.Paste
Sheets(ThisSheet).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Loop
Application.CutCopyMode = False
End Sub

 

[Guest]

Sub Macro1()
ThisSheet = ActiveSheet.Name
Range("B1").Select
ActiveCell.Offset(1, 0).Range("A1").Select
Do Until ActiveCell.Value = ""
ToSheet = ActiveCell.Value
ActiveCell.EntireRow.Copy
Sheets(ToSheet).Select
Range("A1").Select
Selection.End(xlDown).Select
If ActiveCell.Row = 65536 Then
Range("A2").Select
Else
ActiveCell.Offset(1, 0).Range("A1").Select
End If
ActiveSheet.Paste
Sheets(ThisSheet).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Loop
Application.CutCopyMode = False
End Sub

 

[Guest]

Michael,
Try the following. Note: this should also have some error trapping to make
sure the cells in col B actually have a sheet with the same name ( no blanks
or typos)

Sub CopyToSheets()

Dim Rng As Range
Dim oCell As Range

Set Rng = Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each oCell In Rng
oCell.EntireRow.Copy _
Destination:=Sheets(oCell.Value).Range("A65536").End(xlUp).Offset(1,
0)
Next oCell


End Sub

 

[J_J]

David,
When I tried your code (WinXP+XL2003) received a
"Select method of range class failed error" on line
Range("A1").Select
J_J

 

[Tom Ogilvy]

You must be running it from a sheet module.

run it from a general module.

 

[Myrna Larson]

The problem lies in which sheet is the active sheet. It's probably not the
"ToSheet".

Use the other macro you were given. AIR, it was only a couple of lines. It
demonstrates that you don't need to select and activate cells and worksheets
to work with them, and doing so just slows things down.

 

[Guest]

Thank you everyone so much for your replies. I will try it now and report back.