PDA

View Full Version : Solved: copy worksheet to another workbook



PeterNZ
06-07-2010, 12:54 AM
Hi Guys

I have created a timesheet for work and all the guys at work use it but I want it to do a bit more to make their lives a little easier.
Heres the problem... When they have filled their timesheet out for the week I want them to be able to click a button and have vba copy the timesheet(active worksheet) to another workbook (if that workbook not already exist then create it, in the current users MYDOCUMENTS directory) and for the icing on the cake to rename the new sheet in the new workbook as the value of the cell "weekending date" in the workbook. Then clear contents of a named range back in the first(master timesheet) ready for the next weeks entries. Oh and each weeks sheet should be added to the secondary workbook. Forming a database for them to look back at all their timesheets.
Any assistance appriciated .:bow:

adamsm
06-07-2010, 01:50 PM
Try

Set ws = Worksheets("TimeSheet")
Set wb = Application.Workbooks.Open("\\MyDocuments\data\database\TimeSheet.xls")
If Err.Number <> 0 Then
MsgBox Err.Description & "...help"
Else
mytabname = ActiveSheet.Range("a3").Value
ws.Copy after:=wb.Sheets(wb.Sheets.Count)

PeterNZ
06-08-2010, 12:51 AM
Ok adamsm thanks that looks like it will do some of it. I would like to send my workbook in so you could see what I need but I dont know how to attach it to a post. Please advise how to do this .

Aussiebear
06-08-2010, 02:05 AM
To attach a workbook, simply click on Go Advanced, scroll down to Manage Attachments and click that to bring up a window to upload the file. Take note of the limits to the file size. Browse for the file,click upload then scroll back to find the submit post button.

PeterNZ
06-08-2010, 11:29 PM
Here is my workbook for timesheets.
There is three different timesheets as there are three different shifts that are worked. So the macro should copy over the ACTIVESHEET only.
Hope this helps thanks.

GTO
06-09-2010, 01:57 PM
Greetings Peter,

In a test copy of your workbook, try:

Insert two Standard Modules.

In the first Standard Module:

Option Explicit

Sub Main()
Dim _
wbDest As Workbook, _
wksSource As Worksheet, _
wksDest As Worksheet, _
lEndDate As Long, _
MyDocsPath As String, _
SheetName As String, _
bolIsNew As Boolean

'// Change wb name to preference //
Const MY_TIMESHEET As String = "My Timesheet.xls"

'// See function and Chip Pearson's site for a better explanation than I could give.//
MyDocsPath = GetSpecialFolder(CSIDL_MY_DOCUMENTS)
'// If no path is returned, bail out here, else tack on trailing seperator. //
If MyDocsPath = vbNullString Then
Exit Sub
Else
MyDocsPath = MyDocsPath & Application.PathSeparator
End If

'// Set references to the destination wb and the active sheet. //
Set wbDest = GetFile(MyDocsPath, MY_TIMESHEET, bolIsNew)
Set wksSource = ThisWorkbook.ActiveSheet

'// Probably not necessary, but to eliminate any possible issues with returning a //
'// date with slashes... //
lEndDate = wksSource.Range("J2").Value
SheetName = Format(CDate(lEndDate), "mmm dd yyyy")

'// Prevent accidently trying to copy the same week into the destination wb a second//
'// time. //
If ShExists(SheetName, wbDest) Then
wbDest.Close False
MsgBox "The sheet already exists!", vbExclamation, vbNullString
GoTo QuickExit
End If

'// If okay to here, we'll copy to the end of the dest wb. //
wksSource.Copy After:=wbDest.Worksheets(wbDest.Worksheets.Count)

'// Then set a reference to the newly inserted sheet. I think this would be handy //
'// if you add code later to overwrite formulas, data valadation and such, with vals//
'// in the employee's wb. //
Set wksDest = wbDest.Worksheets(wbDest.Worksheets.Count)
wksDest.Name = Format(CDate(lEndDate), "mmm dd yyyy")

'// If we created a new wb, delete the blank sheet. //
If bolIsNew Then
Application.DisplayAlerts = False
wbDest.Worksheets(1).Delete
Application.DisplayAlerts = True
End If
wbDest.Close True

MsgBox "The active sheet has been added to """ & MY_TIMESHEET & """", _
vbInformation, vbNullString

Set wksDest = Nothing
QuickExit:
Set wbDest = Nothing
Set wksSource = Nothing
End Sub

Function GetFile(Path As String, _
WBName As String, _
IsNew As Boolean _
) As Workbook
Dim FSO As Object

Set FSO = CreateObject("Scripting.FileSystemObject")

'// Create a new wb if needed, and set a flag so we'll know its new //
If Not FSO.FileExists(Path & WBName) Then
Set GetFile = Workbooks.Add(xlWBATWorksheet)
GetFile.SaveAs WBName
IsNew = True
Else
Set GetFile = Workbooks.Open(Path & WBName)
IsNew = False
End If

Set FSO = Nothing
End Function

Function ShExists(ShName As String, _
Optional WB As Workbook, _
Optional CheckCase As Boolean = False _
) As Boolean

If WB Is Nothing Then
Set WB = ThisWorkbook
End If

If CheckCase Then
On Error Resume Next
ShExists = CBool(WB.Worksheets(ShName).Name = ShName)
On Error GoTo 0
Else
On Error Resume Next
ShExists = CBool(UCase(WB.Worksheets(ShName).Name) = UCase(ShName))
On Error GoTo 0
End If
End Function

In the second Standard Module:

Option Explicit

'// Functions in this module are taken from examples of Chip Pearson at http://www.cpearson.com
'// See http://www.cpearson.com/Excel/SpecialFolders.aspx

Private Declare Function SHGetFolderPath Lib "shell32.dll" _
Alias "SHGetFolderPathA" (ByVal HWnd As Long, _
ByVal csidl As Long, _
ByVal hToken As Long, _
ByVal dwFlags As Long, _
ByVal pszPath As String _
) As Long
Public Const CSIDL_MY_DOCUMENTS As Long = &H5
Private Const MAX_PATH = 260&
Private Const S_OK = 0&
Private Const E_INVALIDARG As Long = &H80070057
Private Const S_FALSE As Long = &H1 ' odd but true that S_FALSE would be 1.

Public Function GetSpecialFolder(FolderCSIDL As Long) As String

Dim HWnd As Long
Dim Path As String
Dim Res As Long
Dim ErrNumber As Long
Dim ErrText As String

''''''''''''''''''''''''''''''''''''''''''''
' initialize the path variable
''''''''''''''''''''''''''''''''''''''''''''
Path = String$(MAX_PATH, vbNullChar)

''''''''''''''''''''''''''''''''''''''''''''
' get the folder name
''''''''''''''''''''''''''''''''''''''''''''
Res = SHGetFolderPath(HWnd:=0&, _
csidl:=FolderCSIDL, _
hToken:=0&, _
dwFlags:=0&, _
pszPath:=Path)
Select Case Res
Case S_OK
Path = TrimToNull(Text:=Path)
GetSpecialFolder = Path
Case S_FALSE
MsgBox "The folder code is valid but the folder does not exist."
GetSpecialFolder = vbNullString
Case E_INVALIDARG
MsgBox "The value of FolderCSIDL is not valid."
GetSpecialFolder = vbNullString
Case Else
ErrNumber = Err.LastDllError
ErrText = GetSystemErrorMessageText(Res)
MsgBox "An error occurred." & vbCrLf & _
"System Error: " & CStr(ErrNumber) & vbCrLf & _
"Description: " & ErrText
End Select
End Function

Private Function GetSystemErrorMessageText(ErrorNumber As Long) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetSystemErrorMessageText
'
' This function gets the system error message text that corresponds
' to the error code parameter ErrorCode. This value is the value returned
' by Err.LastDLLError or by GetLastError, or occasionally as the returned
' result of a Windows API function.
'
' These are NOT the error numbers returned by Err.Number (for these
' errors, use Err.Description to get the description of the error).
'
' In general, you should use Err.LastDllError rather than GetLastError
' because under some circumstances the value of GetLastError will be
' reset to 0 before the value is returned to VBA. Err.LastDllError will
' always reliably return the last error number raised in an API function.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim ErrorText As String
Dim TextLen As Long
Dim FormatMessageResult As Long
Dim LangID As Long

''''''''''''''''''''''''''''''''
' initialize the variables
''''''''''''''''''''''''''''''''
LangID = 0& 'default language
ErrorText = String$(FORMAT_MESSAGE_TEXT_LEN, vbNullChar)
TextLen = FORMAT_MESSAGE_TEXT_LEN

' Call FormatMessage to get the text of the error message text
' associated with ErrorNumber.
FormatMessageResult = FormatMessage( _
dwFlags:=FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_IGNORE_INSERTS, _
lpSource:=0&, _
dwMessageId:=ErrorNumber, _
dwLanguageId:=LangID, _
lpBuffer:=ErrorText, _
nSize:=TextLen, _
Arguments:=0&)
If FormatMessageResult = 0& Then
' An error occured. Display the error number, but
' don't call GetSystemErrorMessageText to get the
' text, which would likely cause the error again,
' getting us into a loop.

MsgBox "An error occurred with the FormatMessage" & _
" API functiopn call. Error: " & _
CStr(Err.LastDllError) & _
" Hex(" & Hex(Err.LastDllError) & ")."
GetSystemErrorMessageText = vbNullString
Exit Function
End If

' If FormatMessageResult is not zero, it is the number
' of characters placed in the ErrorText variable.
' Take the left FormatMessageResult characters and
' return that text.
ErrorText = Left$(ErrorText, FormatMessageResult)
GetSystemErrorMessageText = ErrorText

End Function

Public Function TrimToNull(Text As String) As String
Dim N As Long
N = InStr(1, Text, vbNullChar)
If N Then
TrimToNull = Left(Text, N - 1)
Else
TrimToNull = Text
End If
End Function

Hope that helps,

Mark

PeterNZ
06-10-2010, 12:42 AM
WOWWWWW!!!!!!!!!!!!!!!!!! Awesome!!!!!!!!!!!!!!!!!
:clap::clap::bow:
GTO You are Awesome That does exactly as I wanted. I bow to your Brilliance!.
Thankyou

GTO
06-10-2010, 01:21 AM
:blush Well... I wouldn't count on any code of mine being brilliant, but thank you of course. I'm glad it worked and hope the comments are helpful.

Mark

PeterNZ
06-10-2010, 02:38 PM
Thanks Mark
Hey there is one more thing I'd like to do and that is...

In the allowances section of the timesheet,when a user picks either "Heat Money" or "Sewerage" and the user has not entered a work order number in the row cell to its left then a msgbox shoud pop up to say "please ensure all allowance claims for "Heat Money" or "Sewerage" have a work order number!.
I'm thinking of using the on_change event of cells where the three letter code that gets auto filled into the cell to the right of the allowance dropdown list as a range that if the above crteria is meet then the pop up happens. I just not sure how to do it.Its the logic combination of the, this OR that AND the third variable.
Please could someone assist me once more?

PeterNZ
06-11-2010, 03:46 AM
Ok I have got it by myself probably bad clunky code but it works ! LOL
I'll add the code here . Hardest thing was getting an event to trigger the Sub when I needed it to. Perhaps someone could give me some advice on events? Thanks again for all your help Guys.

Sub HeatOrSew()

If ActiveCell.Value = "Heat Money" Then
If ActiveCell.Offset(0, -2) = "" Then
MsgBox ("Please enter a WORKORDER Number For all HEAT MONEY Claims")
End If
End If

If ActiveCell.Value = "Sewerage" Then
If ActiveCell.Offset(0, 2) = "" Then
MsgBox ("Please enter a WORKORDER Number For all Sewerage Claims")
End If
End If


End Sub


Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Call HeatOrSew
End Sub

GTO
06-11-2010, 05:18 AM
Hi there,

The calculate event would probably be dependable, but I might try the change event, so that it only ran when I made a change in the particular range of interest.

Not well tested, but try (in ThisWorkbook Module):


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If Target.Count = 1 Then
If Not Application.Intersect(Sh.Range("C49:C57"), Target) Is Nothing _
And Target.Offset(, -2).Value = vbNullString _
And _
(Target.Value = "Heat Money" Or Target.Value = "Sewerage") Then

MsgBox "Please enter a WORKORDER Number For all " & UCase(Target.Value) & " Claims.", _
vbInformation, vbNullString
End If
End If
End Sub

Mark

GTO
06-11-2010, 05:21 AM
BTW,

Please use the little green/white VBA button to insert '...your code tags. It will lay out the code in the post nicely :-)

Mark

PeterNZ
06-11-2010, 02:15 PM
Thanks for your help Mark

On testing the code it I find I get an error '1004' application defined or object defined. This occurs after the MSGBOX has successfully poped up and clicked ok, then get error when enter a workorder number.

GTO
06-11-2010, 11:57 PM
Thanks for your help Mark

On testing the code it I find I get an error '1004' application defined or object defined. This occurs after the MSGBOX has successfully poped up and clicked ok, then get error when enter a workorder number.

My bad, I had the tests combined improperly. Try:


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

If Target.Count = 1 _
And Not Application.Intersect(Sh.Range("C49:C57"), Target) Is Nothing Then

If Target.Offset(, -2).Value = vbNullString _
And (Target.Value = "Heat Money" Or Target.Value = "Sewerage") Then

MsgBox "Please enter a WORKORDER Number For all " & _
UCase(Target.Value) & " Claims.", _
vbInformation, vbNullString
End If
End If
End Sub

If you read through how we did have it, you can see my error. First we tested only to see if it is only one cell changing values. Then we tested to see if Target (the cell changing) intersects our range AND whether the offset of target was empty AND whether Target was one of our two vals of interest. Excel will run all the tests, even if the first one fails, so that is where it jammed when you tried entering anything in column two (or one), as Target.Offset(,-2).Value would be checking a non-existant column.

Mark

PeterNZ
06-12-2010, 12:50 AM
Yes this works well

problem solved thanks GTO.:friends:

michael_au
10-14-2012, 06:12 PM
Here is my workbook for timesheets.
There is three different timesheets as there are three different shifts that are worked. So the macro should copy over the ACTIVESHEET only.
Hope this helps thanks.

I assume that PeterNZ posted his spread sheet here.
I cannot see it??

It would certainly make it easier for me to track the solution if I could see the spreadsheet.

regards,
michael_au

Aussiebear
10-20-2012, 03:18 AM
Hi michael_au,

Sorry but the workbook was not attached as suggested for others to follow, an dyes it does make it very difficult for others to follow the progress of the thread.