Produce a workbook for each employees data in a worksheet

[Bud]

Hello

Each week we run a report of timesheet information and produce that to an
Excel file. From week to week the file will have different number of rows of
data. It is sorted by employee number.

For each employee we want to produce a workbook of that employees data and
than end that routine when there is no more rows of data. How can I do this?

 

[Joel]

Try this code. It will open each week a new Timecard work book using the
GetOpenFilename method (A Pop Up window). the code expects a filename for
each emplooyee using the Employee number as the fileName in Folder (a
variable declared in the macro). Using the Employee number in Column A it
will look for a workbook for the employee and if Not will create the
workbook. The code will create a worksheet using the year Number as the
worksheet name.

The code will copy all the employee rows from the weekly timecard sheet to
the workbook for each employee.

You will need to change the folder name and the worksheet name of the weekly
Workbook where the timecard data is located ("TimeCardData").

Sub CopyToEmployees()

Folder = "c:\EmployeeTime\"

'Get Weekly Employee Time Data"
TimeCardBKName = Application _
.GetOpenFilename("Excel Files (*.xls), *.xls")
If TimeCardBK = False Then
MsgBox ("Can't Open file - Exiting Macro")
Exit Sub
End If

Set TimeCardBK = Workbooks.Open(Filename:=TimeCardBKName)

With TimeCardBK.Sheets("TimeCardData")
RowCount = 1
FirstRow = RowCount 'firstrow is the Starting Row
'Of each employee data
Do While .Range("A" & RowCount) <> ""
'test if last Row of Employyee
'column A contains the employee Number
If .Range("A" & RowCount) <> _
.Range("A" & (RowCount + 1)) Then

'FirstRow willbe the first row of employee data and
'RowCount will be th elast row of employee data

'get rows of data to copy
Set EmployeeRows = _
.Rows(FirstRow & ":" & RowCount)

'set Start row of next Employee
FirstRow = Rowcount + 1
EmployeeNo = .Range("A" & RowCount)
'check if Workbook already exists for employee
FName = Dir(Folder & EmployeeNo & ".xls")
If FName = "" Then
'file doesn't exist creat new workbook
Set EmployeeBK = Workbooks.Add
EmployeeBK.SaveAs _
Filename:=Folder & Employee & ".xls"
'Name the worksheet by Year
EmployeeBK.Sheets("Sheet1").Name = _
"2008"
NewRow = 1
Else
Set EmployeeBK = Workbooks.Open( _
Folder & FName)
End If
'Get this Year worksheet
Set EmployeeSht = EmployeeBK.Sheets(Year(Now()))
With EmployeeSht

If .Range("A1") = "" Then
'If cell A1 is empty then start at row 1
NewRow = 1
Else
'find LastRow
LastRow = _
EmployeeSht.Range("A" & Rows.Count) _
.End(xlUp).Row
NewRow = LastRow + 1
End If

'copy time information
EmployeeRows.Copy Destination:=EmployeeSht.Rows(NewRow)
End With
End If
RowCount = RowCount + 1
Loop
End With

End Sub

 

[Joel]

I n oticed that I didn't close the employees workbook which would leave a lot
of open Workbooks. My code requires one minor change


from
EmployeeRows.Copy Destination:=EmployeeSht.Rows(NewRow)

to

EmployeeRows.Copy Destination:=EmployeeSht.Rows(NewRow)
EmployeeBK.close savechanges:=True

 

[Bud]

See replies

Do you want the data to update the employee workbook regular is this a
one off?, Weekly runs

are you going to run the query manually (click a button) when

you want it to run?, Yes...click a button

are the employee workbooks going to be stored in