Selecting data to copy to new worksheet 1

[willyboy58]

I am trying to separate the following type of information in a spreadsheet. The spreadsheet does not have the headings, which is OK. Below is a tiny subset of the real information. There are over 2000 records in the main file.

Branch EmployeeID Name WorkDate Hours
1 1340 John 05-01-2003 6.0
1 1290 Susie 05-01-2003 6.0
1 1267 Dennis 05-03-2003 7.0
2 1002 Bob 05-01-2003 6.0
2 1222 Steve 05-01-2003 6.0
3 2064 Tom 05-01-2003 8.0
3 1005 Carl 05-02-2003 6.0
3 1111 Kenny 05-01-2003 6.0

I am wanting to select each branch and copy all of it’s people with their work dates and hours to their own worksheet. I will then have four sheets, the one above and one for each branch. I can’t seem to figure out how to start at A1 (which will always start with branch 1) and go to the last record for branch 1 (above would be for Dennis). After this info is copied, go back and start at branch 2 and copy all of branch 2’s people and info to their own worksheet, then do the same for branch 3. There is no way of knowing how many rows of data will be in each branch. Below is what I have so far. It is not working. Any help will be greatly appreciated. TIA. Bill

Sub SeparateBranches3()
Dim FirstCell, NextCell, Lastcell As Range
Dim SourceRange, CopyRows, TargetRange As Range
Dim NumberofRows As Integer

'start at A1
Range("A1&quot.Select

FirstCell = ActiveCell.Value
NextCell = ActiveCell.Offset(1, 0).Value

Do Until NextCell <> FirstCell

With ActiveCell

If NextCell > FirstCell Then
SourceRange = ActiveCell.Offset(-1, 0).Range(FirstCell, NextCell)
CopyRows = SourceRange.Rows.Copy

'create new sheet for info above
Worksheet.Add

'paste info from above
Range(&quot;A1&quot.Select
Selection.PasteSpecial
MsgBox &quot;should be at new sheet&quot;

End If
End With
End
Loop
End Sub

 

[xlbo]

Easiest way would be to use Autofilter (headings would be useful for this)

Sub SeperateData()
dim curVal as long, lRow as long, origSht as worksheet
set origSht = activesheet
lRow = range(&quot;A65536&quot.end(xlup).row

For i = 2 to lRow 'assumes you put headers in
with origSht
if .range(&quot;A&quot; & i).value <> .Range(&quot;A&quot; & i-1).value then
curVal = .range(&quot;A&quot; & i).value
.Range(&quot;A1:E&quot; & lRow).autofilter field:=1, Criteria1:=curVal
worksheets.add
activesheet.name = &quot;Branch &quot; & curVal
.range(&quot;A1:E&quot; & lRow).copy destination:=sheets(&quot;Branch &quot; & curVal)
else
end if
end with
next i
end sub

I've not had time to test this but it should work.....or at least give you an idea..

Rgds
Geoff
Si hoc legere scis, nimis eruditionis habes
Get the best answers to your questions - faq222-2244

 

[willyboy58]

xlbo,

I don't yet understand all the range methods and such so I had to make a small change to a method of worksheets and copying that I have used before. Following is what I have. I have some more work to do for the complete procedure that will involve pivot tables and totaling, but you helped me out a lot! THANKS A TON!!

Sub SeperateDataMyChanges()
Dim curVal As Long, lRow As Long, origSht As Worksheet
Set origSht = ActiveSheet
lRow = Range(&quot;A65536&quot.End(xlUp).Row

For i = 2 To lRow 'assumes you put headers in
With origSht
If .Range(&quot;A&quot; & i).Value <> .Range(&quot;A&quot; & i - 1).Value Then
curVal = .Range(&quot;A&quot; & i).Value
.Range(&quot;A1:F&quot; & lRow).AutoFilter field:=1, Criteria1:=curVal
'changes below here
.Range(&quot;A1:F&quot; & lRow).Copy
Worksheets.Add
ActiveSheet.Name = &quot;Branch &quot; & curVal
Range(&quot;A1&quot.Select
Selection.PasteSpecial
'continue
Else
End If
End With
Next i
End Sub