Move data from sheet to sheet based on ColA

[Steve]

Hi everyone. If I have a sheet called Data, is there a way to have
vba scan all of column A, identify unique values in column A, and then
parse out the entire rows into new sheets? So for instance, if the
values in ColumnA are Blue, Green and Yellow. VBA wold create 3 new
sheets. In the Blue sheet, there would only be records that had Blue
in Column A, and so forth. The only catch is the number of unique
values in ColA can change from month to month. Thanks!

 

[Don Guillett]

Why not just use data>filter>autofilter

 

[Steve]

Hi Don. Because the newly created sheets will be automatically
emailed to the business owners. Also, the sheets will be printed and
added to a monthly book that goes out.

 

[Guest]

Try this code. Change Summary Sheet to match your sheet name for DATA.

Sub ParseSheets()

Const SummarySheet = "Sheet1"

Worksheets(SummarySheet).Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set ColARange = Worksheets(SummarySheet). _
Range(Cells(1, "A"), Cells(LastRow, "A"))

For Each cell In ColARange
If Not IsEmpty(cell) Then
If cell.Row = 1 Then
Worksheets.Add after:=Sheets(Worksheets.Count)
ActiveSheet.Name = cell
cell.EntireRow.Copy Destination:=Rows("$1:$1")
Else
Set PreviousRange = Range(Cells(1, "A"), _
Cells(cell.Row - 1, "A"))
Set c = PreviousRange.Find _
(what:=cell.Value, LookIn:=xlValues)
If c Is Nothing Then
Worksheets.Add after:=Sheets(Worksheets.Count)
ActiveSheet.Name = cell
cell.EntireRow.Copy Destination:=Rows("$1:$1")
Else
Worksheets(cell.Value).Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
cell.EntireRow.Copy Destination:= _
Rows("$" & (LastRow + 1) & ":$" & (LastRow + 1))
End If
End If

End If
Next cell


End Sub

 

[Steve]

Thanks Joel, But got an error on this line:

Worksheets(cell.Value).Activate

 

[Guest]

I changed in two places in the code cell to cell.value. If it fails give me
the data in column A and how far it got before failing. IUt create a
worksheet with a cell name and then later it could not activate the same
worksheet it created. I tsuspect it has to do with the change I made. let
me know the results

Sub ParseSheets()

Const SummarySheet = "Sheet1"

Worksheets(SummarySheet).Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set ColARange = Worksheets(SummarySheet). _
Range(Cells(1, "A"), Cells(LastRow, "A"))

For Each cell In ColARange
If Not IsEmpty(cell) Then
If cell.Row = 1 Then
Worksheets.Add after:=Sheets(Worksheets.Count)
ActiveSheet.Name = cell.value
cell.EntireRow.Copy Destination:=Rows("$1:$1")
Else
Set PreviousRange = Range(Cells(1, "A"), _
Cells(cell.Row - 1, "A"))
Set c = PreviousRange.Find _
(what:=cell.Value, LookIn:=xlValues)
If c Is Nothing Then
Worksheets.Add after:=Sheets(Worksheets.Count)
ActiveSheet.Name = cell.value
cell.EntireRow.Copy Destination:=Rows("$1:$1")
Else
Worksheets(cell.Value).Activate
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
cell.EntireRow.Copy Destination:= _
Rows("$" & (LastRow + 1) & ":$" & (LastRow + 1))
End If
End If

End If
Next cell


End Sub

 

[Guest]

Hi Steve

Have a look at this file I made up recently:

http://users.skynet.be/fa436118/wim/xlwdfiles/kolomtabbladen.xls

That's the direct link to the example, inclusive of the code. Modify to suit
your needs.

There's a page full of explanations on my site http://www.wimgielis.be, but
since that site is in Dutch, linking to it is probably useless in your case.

 

[Don Guillett]

Try this. It will make the sheet if necessary and append the data to the
appropriate sheet.There should be only ONE dot if front of each with segment
such as .range, .showalldata, etc. Assign to a button or shape.

Sub CopyDaily()
Application.ScreenUpdating = False
With Sheets("Data")
lr = .Cells(Rows.Count, "a").End(xlUp).Row
.Range("A1:A" & lr).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
For Each c In .Range("a2:a" & lr).SpecialCells(xlVisible)
On Error Resume Next
If Worksheets(c.Value) Is Nothing Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = c
End If
.ShowAllData
.Range("a1:a" & lr).AutoFilter field:=1, Criteria1:=c
dlr = Sheets(c.Value).Cells(Rows.Count, "a").End(xlUp).Row + 1
.Range("a2:a" & lr).Copy Sheets(c.Value).Range("a" & dlr)
Next c
.ShowAllData
.Range("a1:a" & lr).AutoFilter
End With
Application.ScreenUpdating = True
End Sub

 

[Steve]

Thanks don. The code creates the sheets, but does not copy any data
to them. Looks like the variable dlr is always "empty", and since its
part of the copy to range, never pastes.

 

[Don Guillett]

I just re-tested and it worked,as advertised, to append to the next
available row on each sheet. IF? you only want to do this ONCE then change
to
.Range("a2:a" & lr).Copy Sheets(c.Value).Range("a1")

I am sending you my workbook. Delete all sheets except DATA and try a couple
of times.

 

[Steve]

Thanks Don! I just changed the line you mentioned, and I get the same
thing - many new sheets with no data in each. I'll take a look at
your workbook. I'm sure its something crazy with my data sheet or
structure that will become apparent when I look at yours. Thanks so
much for your help and for sending the file over!! Much appreciated!!

 

[Steve]

Hi Don. Worked like a charm! Must have been something with my
orifginal file!! Thanks for your help!
Can I ask one more question - what if the data in column A is larger
than the allowable amount of characters to rename a sheet? I have one
data point that is 50+ characters, and when the code runs, it simply
creates a sheet called Sheet5 and does not populate it with any data.
Thanks!

 

[Don Guillett]

I can't think of anymore unwieldly as a sheet name that long.
I would make it simple by using a helper column with
xxxxxxxxxxxxxxxx a
yyyyyyyyyyyyyyyy b
name the sheets with the offset name and use a double_click macro to goto
the sheet desired.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As
Boolean)
Application.DisplayAlerts = False
Dim WantedSheet As String
WantedSheet = Trim(ActiveCell.Value)
If WantedSheet = "" Then Exit Sub
On Error Resume Next
If Sheets(ActiveCell.Value) Is Nothing Then
GetWorkbook ' calls another macro to do that
Else
Application.Goto Sheets(ActiveCell.Value).Range("a1")
End If
Application.DisplayAlerts = True
End Sub