View Single Post
  #3   Report Post  
Posted to microsoft.public.excel.programming
Don Guillett Don Guillett is offline
external usenet poster
 
Posts: 10,124
Default Copy Data from one sheet to many based on column A

try this fired from the sheet with the list

Sub copydatatosheetforeach()
Set filtersht = Sheets("sheet2")
For Each c In Range("a3:a" & Cells(Rows.Count, "a").End(xlUp).Row)

With filtersht
lr = .Cells(Rows.Count, "a").End(xlUp).Row
..Range("a1:d" & lr).AutoFilter Field:=1, Criteria1:=c.Value
..Range("A2:D" & lr).SpecialCells(xlCellTypeVisible).Copy

Sheets.Add(After:=Sheets(Sheets.Count)).Name = c
ActiveSheet.Paste

..Range("a1:d" & lr).AutoFilter
End With
Next c
End Sub

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"Steve" wrote in message
...
Hello everyone. I have a data sheet that 14,000 rows long. In column
A is the customer number. Then I have a "control" sheet, where I have
a list of customer numbers to pull (copy) from the data sheet
(A3:A20). Can VBA scan the data sheet, create a new sheet for all
entries in Control("A3:A20"), and copy in the entire row for every
instance found in the data sheet for each customer identified in
Control("A3:A20")?

I have some code below that looks at the data sheet, and based on the
value in column A creates a sheet for each unique instance and copies
the data in. Can this be modified to incorporate the list of values
in the Control sheet? Basically, The data sheet has over 300
customers in column A. I dont want to create 300 sheets! Only about
20, that will be in the list in Control("A1:A20"). Thanks!!

Sub ParseData()

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
Sheets("Data").Select

End Sub