I have 15 sheets, of which I need to loop through all but four sheets named graphs, print, summary and print.
My code only excludes the first sheet and not the other three.
Dim Current As Worksheet
For Each Current In Worksheets
If Current.Name <> "Summary" And Current.Name <> "Model" And Current.Name <> "Print" And Current.Name <> "Graphs" Then
MsgBox Current.Name
Next
End Sub
I am looking to be able to exclude the four sheets in the output. TIA
This should work:
Sub whatever()
Dim Current As Worksheet, c As String
For Each Current In Worksheets
c = Current.Name
If c <> "Summary" And c <> "Model" And c <> "Print" And c <> "Graphs" Then
MsgBox c
End If
Next
End Sub
Sub Sheets_Walk()
Dim ws As Worksheet
For Each ws In Worksheets
If s_in_A1(ws.Name, a1_Names) = False Then
MsgBox ws.Name
End If
Next
End Sub
Function s_in_A1( _
s As String, _
a1 As Variant) _
As Boolean
Dim lCol As Long
For lCol = LBound(a1) To UBound(a1)
If a1(lCol) = s Then
s_in_A1 = True
Exit For
End If
Next
End Function
Function a1_Names() _
As Variant
a1_Names = Array("Summary", "Model", "Print", "Graphs")
End Function
Related
I need the VBA code to select ALL sheets (number and sheet names will vary from time to time) in a workbook except two specific sheets named "Overview" and "Index" (which also happens to be the left-most sheets on the tab list)
Is there "generic" code that can do this without naming each sheet (other than the two sheets that I do NOT want selected)
I tried the below code first to see if I could select all sheets except one:
Sub Macro1()
Dim i As Long
Sheet1.Select
For i = 2 To ThisWorkbook.Sheets.Count
If Sheets(i).Name <> "Overview" Then Sheets(i).Select Replace:=False
Next i
End Sub
but I kept getting a run-time error '1004; message and when I clicked debug it would highlight the "sheet1.slecet" line of code.
Here's an option.
Sub SelectWS()
Dim WS As Worksheet
Dim I As Long
Dim N As Long
Dim Fnd As Boolean
Dim Vis As Boolean
N = 0
For Each WS In ThisWorkbook.Worksheets
Vis = (WS.Visible = xlSheetVisible)
If Vis = False Then N = N + 1
If WS.Name <> "Overview" And WS.Name <> "Index" And Vis Then
Fnd = True
If ActiveSheet.Name = "Overview" Or ActiveSheet.Name = "Index" Then
WS.Activate
WS.Select
Else
WS.Select (False)
End If
End If
Next WS
If Not Fnd Then
MsgBox "No suitable WS found.", vbInformation + vbOKOnly, "Error:"
ElseIf N > 0 Then
MsgBox "Found " & N & " hidden Worksheet(s) - not selectable.", vbInformation + vbOKOnly, "Notice:"
End If
End Sub
Try this:
Sub Macro1()
Dim iSel As Long, ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If IsError(Application.Match(ws.Name, _
Array("Overview", "Index"), 0)) Then
ws.Select Replace:=(iSel = 0) 'only Replace for first-selected sheet
iSel = iSel + 1 'increment selected sheet count
End If
Next ws
End Sub
(assumes no hidden sheets)
I am new to VBA.
Thank you for your time. I have been Googling for 2 days and always get an error.
I have two sheets
Projects ( where I will store project names) and
Template (where new projects will be created using the "template" sheet)
I have 2 issues I am trying to solve :
How do I copy the format on an active sheet including conditional formatting and column width. PasteSpecial already copies all the colour design but not the column width/conditional formatting
When I run the code it creates a new sheet called Project Name,not sure where that is coming from.
This is the code I am using:
Sub Copy()
Sheets("Template").Range("A1:O100").Copy
ActiveSheet.PasteSpecial
End Sub
<<<<<<<<<<<<<<<<<<<<<<
I want to generate a project name, make sure it does not exist(no duplicate), open a new sheet and copy the template from "template".
The full codes is:
RunAll()
CreateProjectName
CreateNewTab
CopyPaste
End Sub
Dim AddData As Range
Dim AddName As String
Set AddData = Cells(Rows.Count, 4).End(xlUp).Offset(1, 0)
AddName = InputBox("Enter Project Name do not input manually", "Project Monitor")
If AddName = "" Then Exit Sub
AddData.Value = AddName
AddData.Offset(0, 1).Value = Now
End Sub
Function SheetCheck(sheet_name As String) As Boolean
Dim ws As Worksheet
SheetCheck = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = sheet_name Then
SheetCheck = True
End If
Next
End Function
Sub CreateNewTab()
Dim sheets_count As Integer
Dim sheet_name As String
Dim i As Integer
sheet_count = Range("D3:D1000").Rows.Count
For i = 1 To sheet_count
sheet_name = Sheets("Projects").Range("D3:D1000").Cells(i, 1).Value
If SheetCheck(sheet_name) = False And sheet_name <> "" Then
Worksheets.Add(After:=Sheets("Projects")).Name = sheet_name
End If
Next i
End Sub
Sub CopyPaste()
Sheets("Template").Range("A1:o100").Copy
ActiveSheet.PasteSpecial
End Sub
Option Explicit
Sub AddProject()
Dim ws As Worksheet, NewName As String
NewName = InputBox("Enter Project Name do not input manually", "Project Monitor")
' checks
If NewName = "" Then
MsgBox "No name entered", vbCritical
Exit Sub
Else
' check sheet not existing
For Each ws In ThisWorkbook.Sheets
If UCase(ws.Name) = UCase(NewName) Then
MsgBox "Existing Sheet '" & ws.Name & "'", vbCritical, "Sheet " & ws.Index
Exit Sub
End If
Next
End If
' check not existing in list
Dim wb As Workbook, n As Long, lastrow As Long, v
Set wb = ThisWorkbook
With wb.Sheets("Projects")
lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row
v = Application.Match(NewName, .Range("D1:D" & lastrow), 0)
' not existing add to list
If IsError(v) Then
.Cells(lastrow + 1, "D") = NewName
.Cells(lastrow + 1, "E") = Now
Else
MsgBox "Existing Name '" & NewName & "'", vbCritical, "Row " & v
Exit Sub
End If
End With
' create sheet
n = wb.Sheets.Count
wb.Sheets("Template").Copy after:=wb.Sheets(n)
wb.Sheets(n + 1).Name = NewName
MsgBox NewName & " added as Sheet " & n + 1, vbInformation
End Sub
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
Hi everyone！ I'm trying to write a method in VBA to keep 2 worksheets and delete others at the same time.
I already did the one that will keep one worksheet and delete others like this:
Sub delete_all_pages_except_main()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Application.DisplayAlerts = False
If ws.Name <> "Home Page" Then
ws.Delete
End If
Next ws
End Sub
And I try to write it like this
If (ws.Name <> "Home Page" Or ws.Name <> "Data")
But VBA would accept it.
Can you guys help? Thank you.
This should do
Sub delete_all_pages_except_main()
Dim ws As Worksheet
Dim arr As Variant
Dim boo As Boolean
Application.DisplayAlerts = False
arr = Array("Home Page", "Data")
For Each ws In ThisWorkbook.Worksheets
boo = NoDel(ws.Name, arr)
If boo <> True Then ws.Delete
Next ws
Application.DisplayAlerts = True
End Sub
Function NoDel(ws As String, warr As Variant) As Boolean
NoDel = False
For i = LBound(warr, 1) To UBound(warr, 1)
If warr(i) = ws Then NoDel = True
Next i
End Function
Delete Sheets With Exceptions
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a specified workbook, writes all the sheet names '
' not specified in an Exceptions array to a Result array, and '
' using the Result array deletes all the sheets in one go. '
' Remarks: This solution applies to worksheets and chartsheets. '
' Since there is no Sheet object, the For Next loop (instead '
' of the For Each Next loop) and the Object type have '
' to be used. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub deleteSheets(Book As Workbook, Exceptions As Variant)
' Program
Dim SheetsCount As Long: SheetsCount = Book.Sheets.Count
Dim Result As Variant: ReDim Result(SheetsCount)
Dim sh As Object, i As Long, j As Long
j = -1
For i = 1 To SheetsCount: GoSub checkName: Next i
If j = -1 Then GoTo NothingToDelete
If j = SheetsCount - 1 Then GoTo NoExceptions
GoSub deleteSheetsInOneGo
MsgBox "Deleted '" & j + 1 & "' sheets.", vbInformation, "Success"
Exit Sub
' Subroutines
checkName:
Set sh = Book.Sheets(i)
If IsError(Application.Match(sh.Name, Exceptions, 0)) Then
j = j + 1
Result(j) = sh.Name
End If
Return
deleteSheetsInOneGo:
ReDim Preserve Result(j)
Application.DisplayAlerts = False
Book.Sheets(Result).Delete
Application.DisplayAlerts = True
Return
' Labels
NothingToDelete:
MsgBox "Sheets already deleted.", vbCritical, "Nothing to Delete"
Exit Sub
NoExceptions:
MsgBox "Cannot delete all sheets.", vbCritical, "No Exceptions"
Exit Sub
End Sub
' Usage Example
Sub runDeleteSheets()
Dim SheetNames As Variant: SheetNames = Array("Home Page", "Data")
deleteSheets ThisWorkbook, SheetNames
End Sub
My goal is to control which worksheet tabs get renamed.
Sub RenameSheets()
Dim I As Long
On Error Resume Next
xTitleld = "Rename Worksheets"
newName = Application.InputBox("Name",xTitleld,"",Type:=2)
For i = 1 To Application.Sheets.Count
If Sheets(i).Name <>"Signature" AND WS.Name <> "Invoice" AND WS.Name `<> "Cover" _
Then Sheeets (i).Name = newName & i
Next
End Sub
I want the worksheet tabs named AR1, AR2, etc. be changed.
I have many other sheets in the workbook. The code is changing all worksheet tabs.
You can try using Select Case ThisWorkbook.Sheets(i).Name, it will simplify and shorten your code a lot. You can also add more names in the future.
Modified Code
Option Explicit
Sub RenameSheets()
Dim i As Long
Dim newName As String, xTitleld As String
xTitleld = "Rename Worksheets"
newName = Application.InputBox("Name", xTitleld, "", Type:=2)
For i = 1 To ThisWorkbook.Sheets.Count
Select Case ThisWorkbook.Sheets(i).Name
Case "Signature", "Invoice", "Cover"
' Do Nothing
Case Else
ThisWorkbook.Sheets(i).Name = newName & i
End Select
Next i
End Sub
You can test whether the characters "AR" appear at the beginning of the name.
Option Explicit
Sub RenameSheets_AR()
Dim I As Long
Dim xTitleld As String
Dim newName As String
' Use only in specific circumstances
'On Error Resume Next
' To increase debugging success see http://www.cpearson.com/excel/errorhandling.htm
xTitleld = "Rename Worksheets"
keyName:
newName = Application.InputBox("Name", xTitleld, "", Type:=2)
If newName = "" Then Exit Sub
For I = 1 To Application.Sheets.Count
If Left(Sheets(I).Name, 2) = "AR" Then
Sheets(I).Name = newName & I
End If
Next
End Sub