Copying rows to different worksheets based on a cells value

[DanSmoach]

I would like to write a macro to loop through each row of a worksheet titled
'Data' and copy each row into seperate worksheets, based on the value in
column A.

Col A Col B Col C etc
Test1 ... ......
Test2 .... ......
Test3 ...... ......
Test2 ...... .......

Row 1 would copy into worksheet 'Test1'
Row 2 would copy into worksheet 'Test2'
Row 3 would copy into worksheet 'Test3'
Row 4 would copy into worksheet 'Test1'

The worksheets to copy into are known and are already set up.

Any help on this problem would be very gratefully received.

Thanks

 

[Norman Jones]

Hi Dan,

Try something like:

'=============>>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim srcSH As Worksheet
Dim Rng As Range
Dim destRng As Range
Dim critRng As Range
Dim arrSheets As Variant
Dim arrKeyWords As Variant
Dim i As Long

Set WB = Workbooks("YourWorkbook.xls") '<<==== CHANGE
Set srcSH = WB.Sheets("Data")
Set Rng = srcSH.Range("A1").CurrentRegion

arrSheets = Array("Test1", "Test2", "Test3")
arrKeyWords = Array("TestA", "TestB", "TestC")

Set critRng = srcSH.Cells(1, Columns.Count). _
End(xlToLeft).Offset(0, 1).Resize(2, 1)
critRng(1).Value = Rng(1).Value

For i = LBound(arrSheets) To UBound(arrSheets)
critRng(2).Value = arrKeyWords(i)
Set SH = Sheets(arrSheets(i))
Set destRng = SH.Cells(Rows.Count, "A").End(xlUp)(2)
Rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=critRng, _
CopyToRange:=destRng, _
Unique:=False
Set destRng = Nothing
Next i

critRng.ClearContents

End Sub
'<<=============

 

[Ron de Bruin]

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