I am trying to find a table ( ListObject ) from a excel workbook ( Lets say workbook 2 ) after opening the same through a VBA subroutine in another workbook ( Lets say workbook 1 ).
The code I tried is as follows ,
Sub B()
Dim TBL_EMP As ListObject
Dim strFile As Variant
Dim WS_Count As Integer
strFile = "File Path"
Set WB_TRN = Workbooks.Open(strFile)
WS_Count = WB_TRN.Worksheets.Count
For n = 1 To WS_Count
On Error GoTo Next_IT
Set TBL_EMP = WB_TRN.Worksheets(n).ListObjects("EmployeeNameTbl")
If Not TBL_EMP Is Nothing Then
MsgBox "Object Found"
End If
Next_IT:
Next n
End Sub
When I run the subroutine it iterate only through 2 sheets and gives error code 9 " ( Subscript Out of Range ) eventhough workbook 2 has 10 worksheets.
If I open the workbook 2 through file open dialogue box then the code works fine.
Please help me to solve this.
Thank you in advance
Referencing a Table in a Workbook
A 'Sub' Example
Sub LocateTableExample()
Const FilePath As String = "C:\Test\Test.xlsx"
Const TableName As String = "EmployeeNameTbl"
Dim wb As Workbook: Set wb = Workbooks.Open(FilePath)
'Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim tbl As ListObject
Dim IsFound As Boolean
Dim ws As Worksheet
For Each ws In wb.Worksheets
On Error Resume Next
Set tbl = ws.ListObjects(TableName)
On Error GoTo 0
If Not tbl Is Nothing Then
IsFound = True
Exit For ' stop looping, it is found
End If
Next ws
' Continue using the 'tbl' and 'ws' variables.
Debug.Print tbl.Name
Debug.Print ws.Name
If IsFound Then
MsgBox "Table found in worksheet '" & ws.Name & "'.", vbInformation
Else
MsgBox "Table not found.", vbCritical
End If
End Sub
Using a Function
The procedure ReferenceTableTest utilizes (calls) the following ReferenceTable function.
Sub ReferenceTableTest()
Const FilePath As String = "C:\Test\Test.xlsx"
Const TableName As String = "EmployeeNameTbl"
Dim wb As Workbook: Set wb = Workbooks.Open(FilePath)
'Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim tbl As ListObject: Set tbl = ReferenceTable(wb, TableName)
If tbl Is Nothing Then Exit Sub
Debug.Print "Get the Names Using the 'tbl' variable"
Debug.Print "Table Name: " & tbl.Name
Debug.Print "Worksheet Name: " & tbl.Range.Worksheet.Name
Debug.Print "Workbook Name: " & tbl.Range.Worksheet.Parent.Name
End Sub
Function ReferenceTable( _
ByVal wb As Workbook, _
ByVal TableName As String) _
As ListObject
Const ProcName As String = "ReferenceTable"
On Error GoTo ClearError
Dim ws As Worksheet
Dim tbl As ListObject
For Each ws In wb.Worksheets
On Error Resume Next
Set tbl = ws.ListObjects(TableName)
On Error GoTo 0
If Not tbl Is Nothing Then
Set ReferenceTable = tbl
Exit For
End If
Next ws
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
Related
This question already has answers here:
Test or check if sheet exists
(23 answers)
Closed 2 months ago.
I am trying to create multiple worksheet in a workbook and name them based on a contents in a particular table. I am doing this as the list can be dynamic and might need to create more/less sheets depending on the requirement.
Sub CreateSheetsFromList()
Dim NewSheet As Worksheet
Dim x As Integer
Dim tbl As ListObject
Dim cell As Range
Application.ScreenUpdating = False
Set tbl = Worksheets("Sheet1").ListObjects("Table1")
For Each cell In tbl.DataBodyRange.Cells
If SheetExists(cell.Value) = False And cell.Value <> "" Then
Set NewSheet = Sheets.Add(after:=Sheets(Sheets.Count))
NewSheet.Name = cell.Value
End If
Next cell
Application.ScreenUpdating = True
End Sub
Function SheetExists(SheetName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = ActiveWorkbook.Worksheets("Sheet1")
On Error GoTo 0
If Not sht Is Nothing Then SheetExists = True
Set sht = Nothing
End Function
Unable to get any kind of results. Please let me know if there is a way to do this in an optimized manner
You have to use the passed variable to check - not a fixed value ("Sheet1"):
Function SheetExists(SheetName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
'Use the passed SheetName to test for
Set sht = ActiveWorkbook.Worksheets(SheetName)
On Error GoTo 0
If Not sht Is Nothing Then SheetExists = True
End Function
Add Sheets From Excel Table (ListObject)
Utilization
Sub AddSheetsFromListObjectTEST()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
AddSheetsFromListObject wb, "Sheet1", "Table1", 1
End Sub
The Method
Sub AddSheetsFromListObject( _
ByVal wb As Workbook, _
ByVal WorksheetID As Variant, _
ByVal ListObjectID As Variant, _
ByVal ListColumnID As Variant)
Const PROC_TITLE As String = "Create Sheets From ListObject"
On Error GoTo ClearError
Dim sws As Worksheet: Set sws = wb.Sheets(WorksheetID)
Dim slo As ListObject: Set slo = sws.ListObjects(ListObjectID)
Dim slc As ListColumn: Set slc = slo.ListColumns(ListColumnID)
Dim srg As Range: Set srg = slc.DataBodyRange
Dim dws As Worksheet, sCell As Range, dName As String, NotRenamed As Boolean
For Each sCell In srg.Cells
dName = CStr(sCell.Value)
If dws Is Nothing Then
Set dws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
End If
On Error GoTo RenameError
dws.Name = dName
On Error GoTo ClearError
If NotRenamed Then NotRenamed = False Else Set dws = Nothing
Next sCell
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
ProcExit:
Exit Sub
RenameError:
'Debug.Print "Name = """ & dName & """" & vbLf & Left(Err.Description, 48)
NotRenamed = True
Resume Next
ClearError:
MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
& Err.Description, vbCritical, PROC_TITLE
Resume ProcExit
End Sub
I have the following in Call.xlsm, A2 contains the path to a second Workbook, Data.xlsm. A3 holds the sheetname I'm trying to copy from Data.xlsm to Call.xlsm.
I understand the first step to copying a sheet from another workbook, is to open it the other workbook (this is in Call.xlsm):
Sub GetData()
Dim filenameIS As String
filenameIS = Worksheets("Sheet1").Range("a2")
Workbooks.Open (filenameIS)
Workbooks(filenameis).WorkSheets("Data 2018").CopyBefore:=ThisWorkbook.Sheets(1))
End Sub
This returns:
Compile error: Synatax error
It doesn't like the :=
Try this:
Sub GetData()
Dim filenameIS As String, wb As Workbook, wsInfo As Worksheet
Set wsInfo = ThisWorkbook.Worksheets("Sheet1")
filenameIS = wsInfo.Range("a2")
Set wb = Workbooks.Open(filenameIS) 'get a reference to the opened workbook
'Copy the worksheet named in A3 over to `wb`
wb.Worksheets(wsInfo.Range("A3").Value).Copy _
Before:=ThisWorkbook.Worksheets(1)
End Sub
Import Sheet From Closed Workbook
Sub ImportSheet()
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Sheets("Sheet1")
Dim sFilePath As String: sFilePath = CStr(dws.Range("A2").Value)
Dim sSheetName As String: sSheetName = CStr(dws.Range("A3").Value)
Dim IsFound As Boolean
IsFound = CreateObject("Scripting.FileSystemObject").FileExists(sFilePath)
If Not IsFound Then
MsgBox "The file '" & sFilePath & "' doesn't exist.", vbExclamation
Exit Sub
End If
Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath)
Dim sws As Object ' if it's a worksheet, use 'Dim sws As Worksheet'
On Error Resume Next
Set sws = swb.Sheets(sSheetName)
On Error GoTo 0
If Not sws Is Nothing Then sws.Copy Before:=dwb.Sheets(1)
swb.Close SaveChanges:=False
If sws Is Nothing Then
MsgBox "Sheet '" & sSheetName & "' doesn't exist.", vbExclamation
Else
MsgBox "Sheet '" & sSheetName & "' imported.", vbInformation
End If
End Sub
i wrote the next code to copy a certain worksheet from my active workbook to multiple woorkbooks but it keeps duplicating the copies,thats my first problem,
the next one i want that code to effect the folder and subfolders inside it how to do it.
the code is:
Option Explicit
Public Sub CopySheetToAllWorkbooksInFolder()
Dim sourceWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim destinationWorkbook As Workbook
Dim folder As String, filename As String
'Worksheet in active workbook to be copied as a new sheet to the destination workbook
Set sourceWorkbook = ActiveWorkbook
Set sourceSheet = sourceWorkbook.Worksheets("pay")
'Folder containing the destination workbooks
folder = "J:\2021\hager\test\"
filename = Dir(folder & "*.xlsx", vbNormal)
While Len(filename) <> 0
Debug.Print folder & filename
Set destinationWorkbook = Workbooks.Open(folder & filename)
sourceSheet.Copy after:=destinationWorkbook.Sheets(1)
destinationWorkbook.ChangeLink Name:=sourceWorkbook.Name, NewName:=destinationWorkbook.Name
destinationWorkbook.Close True
filename = Dir() ' Get next matching file
Wend
End Sub
as pay is the worksheet and the folder is my targeted folder .
Add Worksheet to Multiple Files
This will copy an active workbook's worksheet to all relevant (.xlsx) files in a folder and all of its subfolders (/s).
It will skip the files already containing the worksheet.
If the code is in the workbook containing the worksheet (Pay), replace ActiveWorkbook with ThisWorkbook.
Option Explicit
Sub CopySheetToAllWorkbooksInFolder()
Const ProcName As String = "CopySheetToAllWorkbooksInFolder"
On Error GoTo ClearError
Const dFolderPath As String = "J:\2021\hager\test\"
Const dFilePattern As String = "*.xlsx"
Const swsName As String = "Pay"
Dim fCount As Long
Dim dFilePaths() As String
dFilePaths = ArrFilePaths(dFolderPath, dFilePattern)
If UBound(dFilePaths) = -1 Then Exit Sub ' no files found
Dim swb As Workbook: Set swb = ActiveWorkbook ' ThisWorkbook '
Dim sws As Worksheet: Set sws = swb.Worksheets(swsName)
Dim dwb As Workbook
Dim n As Long
For n = 0 To UBound(dFilePaths)
Debug.Print "Opening... " & dFilePaths(n)
Set dwb = Workbooks.Open(dFilePaths(n))
If Not SheetExists(dwb, swsName) Then
sws.Copy After:=dwb.Sheets(1)
'dwb.ChangeLink swb.Name, dwb.Name ' doesn't work for me
fCount = fCount + 1
Debug.Print "Worksheet added to... " & fCount & ". " & dFilePaths(n)
End If
dwb.Close SaveChanges:=True
Next n
MsgBox "Worksheet inserted in " & fCount & " workbook(s).", vbInformation
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Rte '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the file paths of the files of a folder in an array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "*.*", _
Optional ByVal DirSwitches As String = "/s/b/a-d") _
As Variant
Const ProcName As String = "ArrFilePaths"
On Error GoTo ClearError
Dim pSep As String: pSep = Application.PathSeparator
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
ExecString = "%comspec% /c Dir """ _
& FolderPath & FilePattern & """ " & DirSwitches
Dim Arr() As String: Arr = Split(CreateObject("WScript.Shell") _
.Exec(ExecString).StdOut.ReadAll, vbCrLf)
If UBound(arr) > 0 Then
ReDim Preserve arr(0 To UBound(arr) - 1)
End If
ArrFilePaths = arr
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Rte '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a boolean indicating wether a sheet, defined
' by its name ('SheetName'), exists in a workbook ('wb').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function SheetExists( _
ByVal wb As Workbook, _
ByVal SheetName As String) _
As Boolean
On Error GoTo ClearError
Dim Sh As Object: Set Sh = wb.Sheets(SheetName)
SheetExists = True
ProcExit:
Exit Function
ClearError:
Resume ProcExit
End Function
This loops through workbooks in the folder and subfolders. It only copies the pay sheet if it doesn't exist.
Option Explicit
Public Sub CopySheetToAllWorkbooksInFolder()
Const WS_NAME = "pay"
Const folder = "J:\2021\hager\test\" ' destination workbooks
Dim wbSrc As Workbook, wbDest As Workbook
Dim wsSrc As Worksheet, wsDest As Worksheet
Dim FSO As Object, ts As Object
Dim flds As Collection, fld As Object, f As Object
Dim i As Long, n As Long, bExists As Boolean, logfile As String
' logfile
logfile = Format(Now, "yyyyddmm_HHMMSS") & "_log.txt"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.createTextFile(logfile)
Set wbSrc = ActiveWorkbook
Set wsSrc = wbSrc.Sheets(WS_NAME)
Set flds = New Collection
If FSO.FolderExists(folder) Then
' collection of folders and subfolders
Call GetFolders(FSO, folder, flds)
'scan folders
Application.ScreenUpdating = False
For i = 1 To flds.Count
ts.writeLine "---- Folder = " & flds(i)
' scan folder for files
For Each f In flds(i).Files
If f.Name Like "*.xlsx" Then
Set wbDest = Workbooks.Open(f.Path)
' check if sheet already exists
bExists = False
For Each wsDest In wbDest.Sheets
If wsDest.Name = WS_NAME Then
bExists = True
Exit For
End If
Next
' copy sheet if not exists
If bExists = False Then
wsSrc.Copy after:=wbDest.Sheets(1)
wbDest.ChangeLink Name:=wbSrc.Name, NewName:=wbDest.Name
wbDest.Close savechanges:=True
n = n + 1
ts.writeLine f.Path & " inserted " & WS_NAME
Else
wbDest.Close savechanges:=False
ts.writeLine f.Path & " existing sheet " & WS_NAME
End If
Else
ts.writeLine f.Path & " Skipped"
End If
Next
Next
MsgBox n & " sheets inserted see " & logfile, vbInformation
Else
MsgBox "Folder : " & folder, vbCritical, "Folder not found"
End If
ts.Close
Application.ScreenUpdating = True
End Sub
Sub GetFolders(FSO, s As String, ByRef flds)
Dim fld As Object
Set fld = FSO.getfolder(s)
flds.Add fld
For Each fld In fld.subfolders
Call GetFolders(FSO, fld.Path, flds) ' recurse
Next
End Sub
Please, use the next function, which will return an array of all files matching the ".xls*" extension criteria:
Private Function allFiles(strFold As String, Optional ext As String = "") As Variant 'super, super fast...
Dim arr
arr = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir """ & strFold & """ /b /s").StdOut.ReadAll, vbCrLf), "\")
If ext <> "" Then
Dim arrFin, arrExt, El, i As Long
ReDim arrFin(UBound(arr))
For Each El In arr
arrExt = Split(El, ".")
If arrExt(UBound(arrExt)) Like ext Then
arrFin(i) = El: i = i + 1
End If
Next El
ReDim Preserve arrFin(i - 1)
allFiles = arrFin
Else
allFiles = arr
End If
End Function
Then use it in your code in the next way:
Public Sub CopySheetToAllWorkbooksInFolder()
Dim sourceWorkbook As Workbook, sourceSheet As Worksheet, destinationWorkbook As Workbook
Dim folder As String, arr, El
'Worksheet in active workbook to be copied as a new sheet to the destination workbook
Set sourceWorkbook = ActiveWorkbook
Set sourceSheet = sourceWorkbook.Worksheets("pay")
'Folder containing the destination workbooks
folder = "J:\2021\hager\test\"
arr = allFiles(folder, "xls*")
For Each El In arr
Debug.Print El: Stop 'run the code line by line pressing F8
Set destinationWorkbook = Workbooks.Open(El)
sourceSheet.copy After:=destinationWorkbook.Sheets(1)
destinationWorkbook.ChangeLink Name:=sourceWorkbook.Name, newName:=destinationWorkbook.Name
destinationWorkbook.Close True
Next El
End Sub
When the above code will stop on the line Debug.Print El, run it line by line, pressing F8 and see what happends. If ie work as you need, please comment the code line in discussion and press F5 to run all of it.
Please, send some feedback after testing it.
I'm trying to write a small code in Excel that lets me open in the background another workbook, copy a range of data in there, and then pasty it in the active workboo. Should be pretty straight forward but for some reason I'm getting this error. So far what I've got is this, and I know the error comes from this line "cpyLastRow = ImportBook.cpySheet.Cells(3, 1).End(xlDown).Row", Ive got some variables commented to make it a little bit mor dyanimc in the future. Any ideas?
Private Sub CommandButton2_Click()
Dim OpenFile As Variant
Dim ImportBook As Workbook
Dim cpySheet As Worksheet
Dim cpyLastRow As Long
Dim cpyLastColumn As Long
'Dim cpyStartCell As Range
Set cpySheet = Sheets("DAO")
'Set cpyStartCell = Range("C3")
Application.ScreenUpdating = False
OpenFile = Application.GetOpenFilename(Title:="Select a file to import data", filefilter:="Excel Files (*.xls*),*xls*")
If OpenFile <> False Then
Set ImportBook = Application.Workbooks.Open(OpenFile)
cpyLastRow = ImportBook.cpySheet.Cells(3, 1).End(xlDown).Row
'cpyLastColumn = cpyStartCell.Column
ImportBook.cpySheet.Range("C3", cpySheet.Cells(cpyLastRow, 3)).Copy
ThisWorkbook.ActiveSheet.Range("C3").PasteSpecial xlPasteValues
ImportBook.Close False
End If
Application.ScreenUpdating = True
End Sub
You get an error due to mixing import workbook property and active worbook sheet reference. Try to use method 1 or method 2. Be sure to specify actual sheet name in the import workbook.
'get reference to sheet "ABF - DAO" in active workbook
Set cpySheet = Sheets("ABF - DAO")
...
'error: mix workbook property and sheet reference
cpyLastRow = ImportBook.cpySheet.Cells(3, 1).End(xlDown).Row
'method 1: get reference to sheet in import workbook
Set cpySheet = ImportBook.Sheets("ABF - DAO")
cpyLastRow = cpySheet.Cells(3, 1).End(xlDown).Row
'method 2: get last row without sheet reference
cpyLastRow = ImportBook.Sheets("ABF - DAO")
Copy Column Range From Closed Workbook
Option Explicit
Private Sub CommandButton2_Click()
Const ProcName As String = "CommandButton2_Click"
On Error GoTo clearError
Const sTitle As String = "Select a file to import data"
Const sFilter As String = "Excel Files (*.xls*),*xls*"
Const sName As String = "DAO"
Const sFirst As String = "C3"
Const dFirst As String = "C3"
Dim dSuccess As Boolean
' Source
' Path
Dim sPath As Variant
sPath = Application.GetOpenFilename(Title:=sTitle, FileFilter:=sFilter)
If sPath = False Then
MsgBox "You canceled.", vbExclamation, "Canceled"
GoTo ProcExit
End With
Application.ScreenUpdating = False
' Worksheet
Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
On Error Resume Next
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
On Error GoTo 0
If sws Is Nothing Then
CloseWithoutSaving swb
MsgBox "The worksheet '" & sName & "' does not exist.", _
vbCritical, "No Worksheet"
GoTo ProcExit
End If
' Range
Dim fCell As Range: Set fCell = sws.Range(sFirst)
With fCell
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then
CloseWithoutSaving swb
MsgBox "No data.", vbCritical, "No Data"
GoTo ProcExit
End If
Dim srg As Range: Set srg = .Resize(lCell.Row - .Row + 1)
End With
' Destination
' Assuming that the button is on the Destination Worksheet.
Dim dCell As Range: Set dCell = Range(dFirst)
' Otherwise, you should do something like this:
'Set dCell = ThisWorkbook.Worksheets("DAO").Range(dFirst)
' Copy (by Assignment)
dCell.Resize(srg.Rows.Count).Value = srg.Value
CloseWithoutSaving swb
dSuccess = True
ProcExit:
If Not Application.ScreenUpdating Then
Application.ScreenUpdating = True
End If
If dSuccess Then
MsgBox "Data transferred.", vbInformation, "Success"
End If
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
Sub CloseWithoutSaving( _
ByVal wb As Workbook)
Application.DisplayAlerts = False
wb.Close False
Application.DisplayAlerts = True
End Sub
I have been trying to select one of the sheets called "SYS 6.10.2020". However, this sheet changes its date every week. Is there a VBA code that code could select the sheet based on today's date?
Worksheet Name
The Code
Option Explicit
' If it is the only worksheet that starts with "SYS ", "sys "...
Sub PartialMatch()
Const wsName As String = "SYS "
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
For Each ws In wb.Worksheets
If StrComp(Left(ws.Name, Len(wsName)), wsName, vbTextCompare) = 0 Then
Exit For
End If
Next
If ws Is Nothing Then
'MsgBox "Worksheet starting with '" & wsName _
& "' not found.", vbCritical, "Fail"
Debug.Print "Worksheet starting with '" & wsName & "' not found."
Exit Sub
End If
' Continue with code...
Debug.Print ws.Name
End Sub
Sub ExactMatch()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim wsName As String
wsName = "SYS " & Replace(Format(Date, "d/m/yyyy"), "/", ".")
On Error Resume Next
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
On Error GoTo 0
If ws Is Nothing Then
'MsgBox "Worksheet '" & wsName & "' not found.", vbCritical, "Fail"
Debug.Print "Worksheet '" & wsName & "' not found."
Exit Sub
End If
' Continue with code...
Debug.Print ws.Name
End Sub
Static String
You can do it by supplying the date (formatted in the appropriate format) to the Sheets function.
Quick Sample:
Sheets("SYS 6.10.2020").Select
Dynamic String
Sub Task1()
Dim myDate
myDate = Date
MsgBox myDate
Dim LValue As String
LValue = "SYS " & Format(myDate, "dd.mm.yyyy")
MsgBox LValue
Sheets(LValue).Activate
End Sub
If there is only one sheet added per week, you could use the calendar within vba to find the last date (e.g. last monday) and generate the name from that.