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.
Related
I have created a button that would create a new sheet which works just fine. However, when I created a new sheet with the function, it relocates or redirect me to that new sheet which make. I also have a delete button in which it just accepts the sheet name and delete it instantly with no redirection or relocating. Is there a way to prevent the redirecting from happening? I am still a beginner so if I am doing something wrong, pls kindly correct me! Thanks in advance.
Here is the code.
Option Explicit
Public sheetName As Variant
Sub AddSheet()
On Error Resume Next
sheetName = InputBox("New Sheet Name", "Prototype 01")
If sheetName = "" Then
MsgBox "Sheet name cannot be empty!"
Exit Sub
End If
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sheetName
MsgBox "" & sheetName & " was successfully created!"
End Sub
Sub DeleteSheet()
On Error Resume Next
sheetName = InputBox("Sheet Name", "Prototype 01")
If sheetName = "" Then Exit Sub
Sheets(sheetName).Delete
MsgBox """" & sheetName & """ was successfully removed!"
End Sub
Yo can switch sheets via Worksheet.Activate function of vba.
Sheets("YourSheetName").Activate
Once you create the new sheet, add this code to return back to your original sheet.
Add a Worksheet or Delete a Sheet
It is assumed that the delete code will be called by a button so the active sheet (the one with the button) cannot accidentally be deleted.
Add
Option Explicit
Sub AddSheet()
Const PROC_TITLE As String = "Add Sheet"
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim aws As Worksheet: Set aws = ActiveSheet
Dim wb As Workbook: Set wb = aws.Parent
Dim SheetName As String
SheetName = InputBox("Enter name of sheet to be ADDED", PROC_TITLE)
If Len(SheetName) = 0 Then
MsgBox "Sheet name cannot be empty!", _
vbCritical, PROC_TITLE
Exit Sub
End If
Dim nws As Worksheet
Set nws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
Dim ErrNum As Long
On Error Resume Next ' invalid or existing sheet name
nws.Name = SheetName
ErrNum = Err.Number
On Error GoTo 0
Dim IsSuccess As Boolean
If ErrNum = 0 Then
IsSuccess = True
Else
Application.DisplayAlerts = False
nws.Delete
Application.DisplayAlerts = True
End If
aws.Select
If IsSuccess Then
MsgBox "Worksheet """ & SheetName & """ successfully added.", _
vbInformation, PROC_TITLE
Else
MsgBox "Could not rename to """ & SheetName & """.", _
vbCritical, PROC_TITLE
End If
End Sub
Delete
Sub DeleteSheet()
Const PROC_TITLE As String = "Delete Sheet"
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim aws As Worksheet: Set aws = ActiveSheet
Dim wb As Workbook: Set wb = aws.Parent
Dim SheetName As String
SheetName = InputBox("Enter name of sheet to be DELETED", PROC_TITLE)
If Len(SheetName) = 0 Then
MsgBox "Sheet name cannot be empty!", _
vbCritical, PROC_TITLE
Exit Sub
End If
Dim dsh As Object ' allowing charts to be deleted
On Error Resume Next
Set dsh = wb.Sheets(SheetName)
On Error Resume Next
If dsh Is Nothing Then
MsgBox "There is no sheet named """ & SheetName & """!", _
vbCritical, PROC_TITLE
Exit Sub
End If
' Don't delete the ActiveSheet, the one with the buttons.
If dsh Is aws Then
MsgBox "Cannot delete the 'button' worksheet """ & aws.Name & """!", _
vbCritical, PROC_TITLE
Exit Sub
End If
' A very hidden sheet cannot be deleted. There is no error though.
If dsh.Visible = xlSheetVeryHidden Then
MsgBox "Cannot delete the very hidden sheet """ & SheetName & """!", _
vbCritical, PROC_TITLE
Exit Sub
End If
Application.DisplayAlerts = False
dsh.Delete
Application.DisplayAlerts = True
aws.Select
MsgBox "Sheet """ & SheetName & """ successfully deleted.", _
vbInformation, PROC_TITLE
End Sub
I am trying to send a ticker from one workbook to another when ever it is one I would like to track. When I send it to the other workbook I want to paste the ticker in the next open cell in column JW.
So far my code is as follows:
Sub S2WL()
Dim lst As Long
Dim myVar As String
myVar = ActiveWorkbook.Activesheet.Range(“C2”).Value
With Workbooks("Dash").Sheet("DASH")
lst = .Range("JW" & Rows.Count).End(xlUp).Row + 1
.Range("JW" & lst).PasteSpecial xlPasteValues
End With
End Sub
I'm still very new to VBA and it fails when attempting to pull from my active sheet in workbook Fundamentals. I have multiple sheets that are basically copies in fundamentals. I want a general macro to send C2's value for whatever sheet I am on in Fundamentals to my watchlist in the Workbook Dash column JW. And each time to the next open cell in that column.
Thank you for any and all help!
Copy Value From the Active Sheet
A Qick Fix
Sub S2WLFixed()
Dim MyValue As Variant: MyValue = ThisWorkbook.ActiveSheet.Range("C2").Value
With Workbooks("Dash.xlsx").Worksheets("Dash")
Dim lst As Long: lst = .Cells(.Rows.Count, "JW").End(xlUp).Row + 1
.Cells(lst, "JW").Value = MyValue
End With
End Sub
An Improvement
The following covers most of the issues you may encounter when using the previous code.
Sub S2WL()
' 1. Define constants.
Const ProcName As String = "S2WL" ' for the message boxes
' s - Source (read from)
Const sCellAddress As String = "C2"
' d - Destination (write to)
Const dwbName As String = "Dash.xlsx" ' check if file extension is correct!
Const dwsName As String = "Dash"
Const dColumn As String = "JW"
' 2. Reference the source...
' Reference the workbook containing this code ('swb').
Dim swb As Workbook: Set swb = ThisWorkbook
' Reference the active sheet ('ash').
Dim ash As Object: Set ash = ActiveSheet
' Validate that the active sheet is in the source workbook.
If Not ash.Parent Is swb Then
MsgBox "The active sheet '" & ash.Name & "' is not located in the '" _
& swb.Name & "' workbook.", vbCritical, ProcName
Exit Sub
End If
' Validate that the active sheet is a worksheet.
If ash.Type <> xlWorksheet Then
MsgBox "The active sheet '" & ash.Name & "' is not a worksheet.", _
vbCritical, ProcName
Exit Sub
End If
' Reference the source cell ('sCell').
Dim sCell As Range: Set sCell = ash.Range(sCellAddress)
' 3. Reference the destination...
' Validate the destination workbook ('dwb').
Dim dwb As Workbook
On Error Resume Next
Set dwb = Workbooks(dwbName)
On Error GoTo 0
If dwb Is Nothing Then
MsgBox "The destination workbook '" & dwbName & "' is not open.", _
vbCritical, ProcName
Exit Sub
End If
' Validate the destination worksheet ('dws').
Dim dws As Worksheet
On Error Resume Next
Set dws = dwb.Worksheets(dwsName)
On Error GoTo 0
If dws Is Nothing Then
MsgBox "The destination worksheet '" & dwsName _
& "' does not exist in the '" & dwbName & "' workbook.", _
vbCritical, ProcName
Exit Sub
End If
' Reference the destination cell ('dCell').
Dim dCell As Range
Set dCell = dws.Cells(dws.Rows.Count, dColumn).End(xlUp).Offset(1)
' 4. Copy.
' Write the value from the source cell to the destination cell.
dCell.Value = sCell.Value
' Save the destination workbook (decide on your own).
'dwb.Save
' 5. Inform.
MsgBox "Value copied.", vbInformation
End Sub
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
I' am looking for a code to check Sheet names initially like A, B, C. If sheet A exist then it should run the code which is goto A1: else it should go to B and check if Sheet B exist, if sheet B exist then it should run code below B1, Same way for sheet C as well.
Ex:
For I = 1 to worksheets.count
If Sheets(i).Name = "A" Then
GoTo A1
Else
GoTo B
End If
Next I
I think it can be solved by using ElseIf or Select Case.
Please try with the following 2 cases.
Dim i As Integer
For i = 1 To Worksheets.Count
Select Case Sheets(i).Name
Case "A"
' Coding for "GoTo A1"
Case "B"
' Coding for "GoTo B1"
Case "C"
' Coding for "GoTo C1"
...
End Select
Next i
Or
Dim i As Integer
For i = 1 To Worksheets.Count
If Sheets(i).Name = "A" Then
' Coding for "GoTo A1"
ElseIf Sheets(i).Name = "B" Then
' Coding for "GoTo B1"
ElseIf Sheets(i).Name = "C" Then
' Coding for "GoTo C1"
Else
...
End If
Next i
If you have a specific macro you want to run on each sheet and you want to trigger all of them to run at once, you can organize it like so:
Sub Main()
Call SheetA_Macro
Call SheetB_Macro
Call SheetC_Macro
End Sub
If you have a lot of sheets you can automate the calling of these macros by naming them all the same thing and placing them into the sheet's code module, which would let you call them in this way:
Sub Main()
Dim Sht As Worksheet
For Each Sht In ThisWorkbook.Worksheets
Call ThisWorkbook.Sheets(Sht.Name).MySheetSpecificMacro
Next Sht
End Sub
If you have an unknown sheet and you want to call only that specific sheets macro, then you will want to do it like above but without the loop.
Call ThisWorkbook.Sheets(MyUnknownSheetObject.Name).MySheetSpecificMacro
Remember that the macros must be placed into the sheet's code module and should all be named the same thing.
Worksheet Related Code
Writes the list of worksheet names to an array.
Loops through the array attempting to find an existing worksheet using the WorksheetExists function.
Continues with the worksheet that exists (if any).
Option Explicit
Sub ApplyToFirstFound()
Const wsNamesList As String = "A,B,C"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsNames() As String: wsNames = Split(wsNamesList, ",")
Dim wsName As String
Dim n As Long
For n = 0 To UBound(wsNames)
If WorksheetExists(wb, wsNames(n)) Then
wsName = wsNames(n)
Exit For
End If
Next n
' You could continue with...
If n > UBound(wsNames) Then
MsgBox "No worksheet exists.", vbCritical, "ApplyToFirstFound"
Exit Sub
End If
MsgBox "The first found worksheet is named '" & wsName & "'.", _
vbInformation, "ApplyToFirstFound"
' ... continue...
' ... or with a different code for each worksheet (I've used the same.).
Select Case wsName
Case "A"
MsgBox "Applying to '" & wsName & "'.", _
vbInformation, "ApplyToFirstFound"
Case "B"
MsgBox "Applying to '" & wsName & "'.", _
vbInformation, "ApplyToFirstFound"
Case "C"
MsgBox "Applying to '" & wsName & "'.", _
vbInformation, "ApplyToFirstFound"
Case Else
MsgBox "No worksheet exists.", vbCritical, "ApplyToFirstFound"
End Select
End Sub
Function WorksheetExists( _
ByVal wb As Workbook, _
ByVal WorksheetName As String) _
As Boolean
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
WorksheetExists = Not ws Is Nothing
Exit Function
ClearError:
Resume Next
End Function
I have a workbook with two sheet I copy to the end of the workbook.
I am trying to name the two sheet the same name via a InputBox and give them two different suffix as standard, the first is "xxx - Project" and the next is "xxx - Report".
I have placed the two sheets in an array. How do I reference the two sheet via the InputBox?
Public Sub CopySheets()
Dim shName As String 'Sheet name var
Dim shExists As Boolean
Do
shName = InputBox("Please enter name of new project", "New Project")
If shName <> "" Then
shExists = SheetExists(shName) 'Check for existing sheet name
If Not shExists Then
Worksheets(Array(1, 2)).Copy After:=Sheets(Sheets.Count)
Else
MsgBox "Project Name:" & Space(1) & shName & " already exists", vbOKOnly + vbCritical, "Deter"
End If
End If
Loop Until Not shExists Or shName = ""
End Sub
Private Function SheetExists(ByVal sheetName As String, _
Optional ByVal wb As Workbook)
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
SheetExists = Not wb.Worksheets(sheetName) Is Nothing
End Function
Sample image:
Something like that in in the if conditon
If Not shExists Then
Worksheets(Array(1, 2)).Copy After:=Sheets(Sheets.Count)
Dim ws As Worksheet
Set ws = Sheets(Sheets.Count - 1)
ws.Name = shName & "- project"
Set ws = Sheets(Sheets.Count)
ws.Name = shName & "- report"
Else