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
Reply With Quote
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.
Originally Posted by PeterNZ
