macro- using date in one ws to move to various new ws's

[gdh05]

I am trying to write a macro where I separate groups into different sheets. Basically, I have a list of people in different 4-digit departments that have to each go into their department number's sheet. However, sheets have to be created for each dept number as they don't exist already. Also, these dept number sheets have to be based off of a form sheet that already exists (so copied and renamed for each dept #).

for example:

3344 joe smith
3344 steve smith
4455 john jones
4455 john smith

I don't know how to make it go as follows (for example):

if dept number is greater than the one before (ie. is 4455 greater than 3344? yes, so create a new "4455" sheet and move that person's info over to it. Then, is 4455 greater than 4455? no, so just move that person's info into the "4455" sheet that is already there). and so on...

Can this be done? how do I make it look at the person's dept number in the previous row to compare to? can it be "stored" somewhere and move in and out for each person in the list?

also, I can't hardcode dept numbers in as they will constantly changing...
I have read through 3 vba books and can't find anything that will help me do what I'm trying to do, so any help is greatly appreciated!!

Thanks so much again for any help.

[Killian]

Hi and welcome to VBAX

I was wondering why you need to check the previous row - would the following logic work?
For each record, if dept# doest have sheet, create sheet for dept#
Add name to dept# sheet.
Which would look something like this[VBA]Sub ProcessNames()

Dim rngSource As Range
Dim rngSourceRow As Range
Dim strDeptNum As String
Dim shtNewSheet As Worksheet

'source data on "Sheet1"
'starts in A:1 and is contiguous
Set rngSource = Worksheets("Sheet1").Cells(1, 1).CurrentRegion

For Each rngSourceRow In rngSource.Rows
strDeptNum = rngSourceRow.Cells(1, 1).Text
If Not SheetExists(strDeptNum) Then
Set shtNewSheet = Worksheets.Add
shtNewSheet.Name = strDeptNum
Set shtNewSheet = Nothing
End If
rngSourceRow.Copy Destination:=Worksheets(strDeptNum).Rows(GetNextRow(strDeptNum))
Next

End Sub

'######################################################
'Functions

Function SheetExists(strSheetName As String) As Boolean
'function to see if a sheet exists
Dim sht As Worksheet

SheetExists = False
For Each sht In ActiveWorkbook.Worksheets
If sht.Name = strSheetName Then
SheetExists = True
Exit For
End If
Next

End Function

Function GetNextRow(strSheetName As String) As Long
'function to return the next available row
GetNextRow = Worksheets(strSheetName).Cells(Rows.Count, 1).End(xlUp).Row + 1
End Function[/VBA]

[Bob Phillips]

[VBA]
Sub Test()
Dim this As Worksheet
Dim sh As Worksheet
Dim iLastRow As Long
Dim iStart As Long, iEnd As Long
Dim i As Long
Dim sTemp

Set this = ActiveSheet
sTemp = Range("A1").Value
iStart = 1
With this
iLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To iLastRow + 1
If .Cells(i, "A").Value <> sTemp Then
iEnd = i - 1
Set sh = Worksheets.Add
sh.Name = sTemp
.Rows(iStart).Resize(iEnd - iStart + 1).Copy sh.Range("A1")
iStart = i
sTemp = .Cells(i, "A").Value
End If
Next i
End With

End Sub
[/VBA]

[gdh05]

xld and killian,

Thank you both so much!! Those do work great, however, the issue is that I have 2 sheets - Database (of the employee info) and SalaryCalc (a "template" where the info needs to go. there are many other formula calcs done there with the info moved from the database). Right now, the code just copies all of the employee info from the DB and pastes it into a new sheet for each dept number. What it needs to do is take only columns a-e in Database for each person in the dept and copy them into SalaryCalc which is copied as a new sheet for that dept number. Make sense? I am just so lost on how to do that.

Thanks again!!

[gdh05]

I guess I can find a way around my last question, but can you tell me how to stop this without the error message when it gets to the last dept number. I need it to go into another macro but it keeps kicking out when it hits the end...

thanks again

[Killian]

If you only want to copy cols a-e from the row, change the source range with Resize.
And instead of adding a new worksheet, you want to copy an existing one...
So the loop in the example I gave would change to this e.g.[VBA]For Each rngSourceRow In rngSource.Rows
strDeptNum = rngSourceRow.Cells(1, 1).Text
If Not SheetExists(strDeptNum) Then
Worksheets("SalaryCalc").Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = strDeptNum
Set shtNewSheet = Nothing
End If
rngSourceRow.Resize(1, 5).Copy Destination:=Worksheets(strDeptNum).Rows(GetNextRow(strDeptNum))
Next[/VBA]

And there's an error when it gets to the end???
What is it?