I have a code that deletes a tab in the worksheet then runs another code. I am currently running into an issue that if the sheet is not there the code gives me an error... I'm wondering if I could make an if statement that looks if the tab is there and if not it moves on and if it is there it will delete it. I have the code that I have written already posted below but I have no idea how to do the if in the delete section.
Thanks!
Sub delete()
Dim ws As Worksheet
Set ws = Worksheets("Workbench Report")
Application.DisplayAlerts = False
ws.delete
Call Sorting
End Sub
Check if the sheet exists first:
Sub delete()
Dim ws As Worksheet
If WorksheetExists("Workbench Report") Then
Set ws = Worksheets("Workbench Report")
Application.DisplayAlerts = False
ws.delete
Call Sorting
End If
End Sub
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Try this
Sub delete()
Dim i As Integer
i = 1
Application.DisplayAlerts = False
While i <= ActiveWorkbook.Worksheets.Count
Sheets(i).Select
If ActiveSheet.Name = "Workbench Report" Then
ActiveSheet.delete
End If
i = i + 1
Wend
Call Sorting
Application.DisplayAlerts = True
End Sub
Related
I am trying to embed applying a chart template into a macro and require help.
I have this code for the Macro that I am using to create scatter plots:
Option Explicit
Public Sub Test()
' Keyboard Shortcut: Ctrl+Shift+X
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1") 'change as appropriate
Application.ScreenUpdating = False
BuildChart ws, SelectRanges(ws)
Application.ScreenUpdating = True
End Sub
Private Function SelectRanges(ByRef ws As Worksheet) As Range
Dim rngX As Range
Dim rngY As Range
ws.Activate
Application.DisplayAlerts = False
On Error Resume Next
Set rngX = Application.InputBox("Please select X values. One column.",
Type:=8)
If rngX Is Nothing Then GoTo InvalidSelection
Set rngY = Application.InputBox("Please select Y values. One column.",
Type:=8)
If rngY Is Nothing Then GoTo InvalidSelection
If rngX.Columns.Count > 1 Or rngY.Columns.Count > 1 Then GoTo
InvalidSelection
On Error GoTo 0
Set SelectRanges = Union(rngX, rngY)
Application.DisplayAlerts = True
Exit Function
InvalidSelection:
If rngX Is Nothing Or rngY Is Nothing Then
MsgBox "Please ensure you have selected both X and Y ranges."
ElseIf rngX.Rows.Count <> rngX.Rows.Count Then
MsgBox "Please ensure the same number of rows are selected for X and Y
ranges"
ElseIf rngX.Columns.Count > 1 Or rngY.Columns.Count > 1 Then
MsgBox "Please ensure X range has only one column and Y range has only
one column"
Else
MsgBox "Unspecified"
End If
Application.DisplayAlerts = True
End
End Function
Private Sub BuildChart(ByRef ws As Worksheet, ByRef unionRng As Range)
With ws.Shapes.AddChart2(240, xlXYScatter).Chart
.SetSourceData Source:=unionRng
End With
ActiveChart.ApplyChartTemplate ( _
"C:\Users\maaro\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
End Sub
And would like to embed this code below into the above code so that it applies the template to the chart I create whenever I run this Macro. My initial guess would be to put it underneath "Private Sub BuildCharts". How would I be able to do this? Thank you.
ActiveChart.ApplyChartTemplate ( _
"C:\Users\XXXXX\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
Perhaps modify Sub BuildChart like this:
Private Sub BuildChart(ByRef ws As Worksheet, ByRef unionRng As Range)
With ws.Shapes.AddChart2(240, xlXYScatter).Chart
.SetSourceData Source:=unionRng
.ApplyChartTemplate ( _
"C:\Users\maaro\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
End With
End Sub
I have created a Workbook that is used in various different computers.
Sometimes I add features to it and I would like to easily update it.
The idea is whenever I have a new version of it, I take it to a new computer, save in a temp file and copy the sheets where the data is stored.
Based on the answers I have edit my first draft to: (I didn't know that both workbooks needed to be opened at the same time)
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim ws As Worksheet
Dim wb As Workbook
Dim wn As Workbook
Set wn = Workbooks("Reception")
Set wb = Workbooks("Reception2")
With wb
.Sheets("Pass").Range("A1") = "flh"
For Each ws In .Worksheets
Select Case .Name
Case "Formularios", "Coordenador", "LookupList", "Pass"
'Do nothing
Case Else
ws.Delete
End Select
Next ws
End With
With wn
For Each sh In .Worksheets
Select Case .Name
Case "Formularios", "Coordenador", "LookupList", "Pass"
'Do nothing
Case Else
sh.Copy After:=wb.Sheets(wb.Sheets.Count)
End Select
Next sh
End With
End Sub
Case at moment is not working and macro deletes every sheet no matter the name
Thank you all for the feedback
You can find the temp folder by using Environ("temp"), but from your code I'm not sure this is the folder you're using.
This code has a couple of functions to check if the workbook exists and is already open. One other bit of code I'd add is to disable any code in Reception.xlsm from firing when it's opened.
Public Sub MyProcedure()
Dim ws As Worksheet
Dim wb As Workbook
Dim wn As Workbook
Dim Rec1Path As String
Dim Rec2Path As String
Rec1Path = "c:\save\Reception.xlsm"
Rec2Path = "c:\temp\Reception2.xlsm"
'Open or set a reference to Reception.xlsm.
If WorkBookExists(Rec1Path) Then
If WorkBookIsOpen(Rec1Path) Then
'Don't need path for open workbook, just name.
'InStrRev finds last occurrence of "\" (same as InStr, but in Reverse).
Set wn = Workbooks(Mid(Rec1Path, InStrRev(Rec1Path, "\") + 1))
Else
Set wn = Workbooks.Open(Rec1Path)
End If
End If
'Open or set a reference to Reception2.xlsm.
If WorkBookExists(Rec2Path) Then
If WorkBookIsOpen(Rec2Path) Then
Set wb = Workbooks(Mid(Rec2Path, InStrRev(Rec2Path, "\") + 1))
Else
Set wb = Workbooks.Open(Rec2Path)
End If
End If
With wb
.Worksheets("Pass").Range("A1") = "flh"
For Each ws In .Worksheets
Select Case .Name
Case "Formularios", "Coordenador", "LookupList", "Pass"
'Do nothing
Case Else
'You don't really need the count of worksheets if you can guarantee
'you're not going to try and delete the last remaining sheet.
If .Worksheets.Count > 1 Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End Select
Next ws
End With
With wn
'Re-using the ws variable.
For Each ws In .Worksheets
Select Case .Name
Case "Formularios", "Coordenador", "LookupList", "Pass"
'Do nothing
Case Else
ws.Copy After:=wb.Sheets(wb.Sheets.Count)
End Select
Next ws
End With
End Sub
Public Function WorkBookExists(sPath As String) As Boolean
WorkBookExists = Dir(sPath) <> ""
End Function
Public Function WorkBookIsOpen(FullFilePath As String) As Boolean
Dim ff As Long
On Error Resume Next
ff = FreeFile()
Open FullFilePath For Input Lock Read As #ff
Close ff
WorkBookIsOpen = (Err.Number <> 0)
On Error GoTo 0
End Function
Is the workbook open when you try to 'SET' it? If not you will need to open it as such:
Dim wb As Workbook
Set wb = Workbooks.Open("c:\temp\Reception.xlsm")
With some more googling I was able to craft the code that I wanted in the end.
Here is the answer for the curious or for other people looking to do the same:
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim ws As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim j As Long
Dim Rng As Range
Dim wb As Workbook
Dim wn As Workbook
Set wn = Workbooks("Reception")
Set wb = Workbooks("Reception2")
With wb
.Sheets("Pass").Range("A1") = "flh"
For Each ws In .Worksheets
Select Case ws.Name
Case "Formularios"
'Do nothing
Case "Coordenador"
'Do nothing
Case "LookupList"
'Do nothing
Case "Pass"
'Do nothing
Case Else
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set Rng = .Range(.Cells(2, 1), .Cells(LastRow, LastCol))
Rng.ClearContents
End With
End Select
Next ws
End With
With wn
For Each sh In .Worksheets
Select Case sh.Name
Case "Formularios"
'Do nothing
Case "Coordenador"
'Do nothing
Case "LookupList"
'Do nothing
Case "Pass"
'Do nothing
Case Else
For j = 1 To wb.Sheets.Count
If sh.Name = wb.Worksheets(j).Name Then
On Error Resume Next
sh.Range("A:J").Copy wb.Worksheets(j).Range("A1")
End If
Next j
End Select
Next sh
End With
Application.CutCopyMode = False
End Sub
Thanks to #Darren Bartrup-Cook for the help.
I am looking for a way to create sheets in excel based on a list of cells
problem I have is that I would like the script to check if the list was updated and add the additional sheets and not re create all or delete the old copies
1) is it possible from excel (non VBA)
2) if not the code i have for creating a sheet is :
but it will create new entrys if I re-run (and I am looking for update)
Sub AddSheets()
'Updateby Extendoffice 20161215
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A1:A7")
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
End Sub
Here's another option. I also added a part where it'll name the sheet the column A value. (You can remove that if needed).
Sub AddSheets()
'Updateby Extendoffice 20161215
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A1:A7")
With wBk
If Not sheetExists(xRg.Value) and xRg <> "" Then
.Sheets.Add after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = xRg.Value
End If
End With
Next xRg
Application.ScreenUpdating = True
End Sub
Function sheetExists(sheetToFind As String) As Boolean
'http://stackoverflow.com/a/6040454/4650297
Dim sheet As Worksheet
sheetExists = False
For Each sheet In Worksheets
If sheetToFind = sheet.Name Then
sheetExists = True
Exit Function
End If
Next sheet
End Function
Use this function to check if the worksheet already exists, then let it skip over it.
Function WorksheetExists(sName As String) As Boolean
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
So your code can be:
Sub AddSheets()
'Updateby Extendoffice 20161215
Dim xRg As Variant
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("A1:A7")
If Not IsError(xRg) Then
If xRg <> "" Then
If Not WorkSheetExists((xRg)) Then
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = xRg.Value
End With
End If
End If
End If
Next xRg
Application.ScreenUpdating = True
End Sub
Function WorksheetExists(sName As String) As Boolean
WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
I am having problem to solve the error "time execution error #13: incompatible type". If user creates some worksheet that is not stated in the array, it will be deleted. Can anyone help?
sub DeleteNewSheets()
Dim ws, wsP As Worksheet
Dim ArrayOne As Variant
Application.DisplayAlerts = False
ArrayOne = Array("SheetA", "SheetB", "SheetC", "Sheet_n")
Set wsP = ThisWorkbook.Worksheets(ArrayOne) ' <--- ERROR #13
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> wsP.Name Then ws.Delete
Next ws
Application.DisplayAlerts = True
end sub
Your line of code saying:
Set wsP = ThisWorkbook.Worksheets(ArrayOne)
is trying to set a Worksheet object to an array of many Worksheets. That's like trying to set a single Integer to be an array of Integers.
Try using the following code
Sub DeleteNewSheets()
Dim ws As Worksheet
Dim ArrayOne() As Variant
Dim wsName As Variant
Dim Matched As Boolean
ArrayOne = Array("SheetA", "SheetB", "SheetC", "Sheet_n")
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
Matched = False
For Each wsName In ArrayOne
If wsName = ws.Name Then
Matched = True
Exit For
End If
Next
If Not Matched Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True
End Sub
If you add an extra For ... Next or For Each ... Next statement to loop through every element in ArrayOne and conditional IFs statement then it should do the work. So your code should be like this
Sub DeleteNewSheets()
Dim ws As Worksheet
Dim ArrayOne As Variant, iSheet As Integer
Application.DisplayAlerts = False
ArrayOne = Array("SheetA", "SheetB", "SheetC", "Sheet_n")
For Each ws In ThisWorkbook.Worksheets
For iSheet = LBound(ArrayOne) To UBound(ArrayOne)
If ws.Name = ArrayOne(iSheet) Then Exit For
If iSheet = UBound(ArrayOne) Then
ws.Delete
End If
Next
Next
Application.DisplayAlerts = True
End Sub
or alternatively
Sub DeleteNewSheets()
Dim ws As Worksheet
Dim ArrayOne As Variant
Application.DisplayAlerts = False
ArrayOne = Array("SheetA", "SheetB", "SheetC", "Sheet_n")
For Each ws In ThisWorkbook.Worksheets
For Each Element In ArrayOne
If ws.Name = Element Then Exit For
If Element = ArrayOne(UBound(ArrayOne)) Then
ws.Delete
End If
Next
Next
Application.DisplayAlerts = True
End Sub
you can check sheets in one loop and delete "bad" ones in one shot as follows:
Option Explicit
Sub DeleteNewSheets()
Dim ws As Worksheet
Dim sheetsToDelete As String
Const GOODSHEETS As String = "\SheetA\SheetB\SheetC\Sheet_n\" '<--| list of good sheets names, separated by an invalid character for sheet names
For Each ws In ThisWorkbook.Worksheets
If InStr(GOODSHEETS, "\" & ws.Name & "\") = 0 Then sheetsToDelete = sheetsToDelete & ws.Name & "\" '<--| update sheets to be deleted list
Next ws
If sheetsToDelete <> "" Then '<--| if the list is not empty
sheetsToDelete = Left(sheetsToDelete, Len(sheetsToDelete) - 1) '<--| remove last delimiter ("\") from it
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(Split(sheetsToDelete, "\")).Delete '<-- delete sheets
Application.DisplayAlerts = True
End If
End Sub
I am working with a file where the worksheets have been renamed. Instead of Sheet1(generic name) it is Hoja1(generic name).
Wondering if this is stopping my code from working.
My code is very simple. I dont know what other error I could be having.
Sub Macro1()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Application.DisplaysAlerts = False
If LenB(ActiveSheet.Range("A5")) = "" Then ActiveSheet.Delete
Application.DisplayAlerts = True
Next ws
End Sub
Thank you.
If it's definitely going to have "Hoja" in the sheet name, this should work.
Sub Macro1()
Dim WS As Worksheet
Application.DisplayAlerts = False
For Each WS In ActiveWorkbook.Sheets
If InStr(WS.Name, "Hoja") <> 0 Then WS.Delete
Next
Application.DisplayAlerts = True
End Sub
Got some help from someone.
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Application.DisplayAlerts = False
If LenB(ws.Range"A5")) = 0 Then ws.Delete
Application.DisplayAlerts = True
Next ws
The spanish wasn't the issue.
To get the name Hoja1 if the sheet appears as Hoja1(1) in the VBA browser you can use the .CodeName property:
'code borrowed from Alex's answer
Sub Macro1()
Dim WS As Worksheet
Application.DisplayAlerts = False
For Each WS In ActiveWorkbook.Sheets
If InStr(WS.CodeName, "Hoja") <> 0 Then WS.Delete
Next
Application.DisplayAlerts = True
End Sub