Solved: Specify data range and copy to other sheet

[danlu]

Hi,

I have a large amount of data which is ordered by the values in the A column, that is, first is all data which has the word alpha listed, then comes all data with value beta and so on. For ex column A,B and C could look like this:
alpha 10 20
alpha 10 20
beta 15 cat
beta dog 12

so I want to copy all data (from column A,B and C) with value alpha in column A on Sheet1 to Sheet3, all data with value beta in column A on sheet1 to Sheet4 and so on.
Which would give the following look at Sheet3 (in column A,B and C):
alpha 10 20
alpha 10 20
and sheet4 would look like:
beta 15 cat
beta dog 12

and go on like this on every unique Sheet for as many sheets as there are unique values(categories) in column A on Sheet1.
If possible it would be good if each tab could be named the same thing as the name of the value (category) that ends up on that specific sheet. For ex the sheet (in this ex sheet3) which ends up with data belonging to value alpha in column A should be named Alpha.
To have data belonging to a value in column A in only two columns was only an example. Generally there are data in more columns and of course all attached data (not only data in column B,C) should be copied to the unique sheet dedicated for a unique value (category) in column A from sheet1.

[mikerickson]

Does your source data have unique headers at every column head?

[Bob Phillips]

Option Explicit

Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim NextRow As Long
Dim this As Worksheet
Dim sh As Worksheet

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Set this = ActiveSheet
With this

LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
For i = 2 To LastRow

Set sh = Nothing
On Error Resume Next
Set sh = Worksheets(.Cells(i, "A").Value)
On Error GoTo 0
If sh Is Nothing Then

Worksheets.Add after:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
sh.Name = .Cells(i, "A").Value
.Rows(1).Copy sh.Range("A1")
End If

NextRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row + 1
.Rows(i).Copy sh.Cells(NextRow, "A")
Next i

End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

[danlu]

Hi,

Mike, Yes there is a header for every column on row A.
Xld, I just tried out your solution and it works great! Thanks a lot!