I need help to check why below VBA code take longer time while execute, its being more faster once test at first trials but now its take may be 10 - 20 mints although the data not more than 500 Row & 15 Columns
Sub Cell_Formatting()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name = "1" Or ws.Name = "2" Or ws.Name = "3" Or ws.Name = "4" Then
ws.Select
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Range("A1:O" & lastRow).Select
For Each self In Selection.SpecialCells(xlCellTypeConstants)
With Selection
.Borders.Weight = xlThin
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next
End If
Next ws
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I don't believe you need a loop over each individual cell:
For Each ws In Worksheets
If ws.Name = "1" Or ws.Name = "2" Or ws.Name = "3" Or ws.Name = "4" Then
Dim rng As Range
Set rng = Nothing
On Error Resume Next
Set rng = ws.Columns("A:O").SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If not rng Is Nothing Then
rng.Borders.Weight = xlThin
rng.HorizontalAlignment = xlCenter
rng.VerticalAlignment = xlCenter
End If
End If
Next
Related
Kindly advice how to stop macro automatically from running when it reach last sheet, as I get run time error at the end
Sub ACT1()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Application.ScreenUpdating = False
Range("B:B").Select
With Selection
.NumberFormat = "General"
.Value = .Value
.HorizontalAlignment = xlLeft
End With
Sheets(ActiveSheet.Index + 1).Activate
Debug.Print ws.Name
Next ws
End Sub
I have try to use
If folder.Show <> -1 Then Exit Sub
but It do not help
Try this. Your code fails because you are trying to activate the next worksheet from the current one so when you get to the end, there is no more sheets to activate.
Sub ACT1()
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
With ws.Range("B:B")
.NumberFormat = "General"
.Value = .Value
.HorizontalAlignment = xlLeft
End With
Debug.Print ws.Name
Next ws
Application.ScreenUpdating = True
End Sub
I am trying to learn the macros and building a code to hide the specific sheets by giving yes or no. used the below code but getting script error
In the master sheet, i have mentioned all the sheet names in Col H (Row#5 onwards) and mentioned "Yes" or "No" for either making visible or hiding the same
Sub Button2_Click()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Master")
Dim i
Application.ScreenUpdating = False
For i = 4 To ws.Range("I" & ws.Rows.Count).End(xlUp).Row
If ws.Range("I" & i) = "Yes" Then
ThisWorkbook.Sheets(i - 2).Visible = xlSheetVisible
ElseIf ws.Range("I" & i) = "No" Then
ThisWorkbook.Sheets(i - 2).Visible = xlSheetHidden
End If
Next i
Application.ScreenUpdating = True
End Sub
This will Work:
Sub Button2_Click()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Master")
Dim i As Integer
Application.ScreenUpdating = False
For i = 5 To ws.Range("I" & ws.Rows.Count).End(xlUp).Row
If ws.Range("I" & i) = "Yes" Then
ThisWorkbook.Worksheets(ws.Range("H" & i).Value).Visible = xlSheetVisible
ElseIf ws.Range("I" & i) = "No" Then
ThisWorkbook.Worksheets(ws.Range("H" & i).Value).Visible = xlSheetHidden
End If
Next i
Application.ScreenUpdating = True
End Sub
I want to delete all the sheets in the workbook except month end sheets for a given year eg of sheet names all sheet names are entered in this format dd.mm.yy
I tried other codes like case instead of If but all codes seems to stop at ws.delete
Sub Delete_Sheets
Yr = InputBox("Use YY format only.", "Which year to keep?", 18)
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "31.01.Yr" Or ws.Name <> "28.02.Yr" Or ws.Name <> "31.03.Yr" Or ws.Name <> "30.04.Yr" Or ws.Name <> "31.05.Yr" Or ws.Name <> "30.06.Yr" Or ws.Name <> "31.07.Yr" Or ws.Name <> "31.08.Yr" Or ws.Name <> "30.09.Yr" Or ws.Name <> "31.10.Yr" Or ws.Name <> "30.11.Yr" Or ws.Name <> "31.12.Yr" Then
ws.Delete
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Use Application.InputBox method instead of InputBox only. This one has a Type:=1 parameter that forces the user to enter numbers only.
Make sure you test for ThisWorkbook.Worksheets.Count > 1 because you cannot delete the last worksheet. At least 1 worksheet must remain.
Put all the sheets you want to skip into an array SkipSheets and filter that array for your worksheet name (UBound(Filter(SkipSheets, ws.Name)) > -1)
Option Explicit
Public Sub DeleteSheets()
Dim InputYear As Variant
InputYear = Application.InputBox(Prompt:="Use YY format only.", Title:="Which year to keep?", Default:=18, Type:=1)
If VarType(InputYear) = vbBoolean And InputYear = False Then Exit Sub 'user pressed cancel
Dim SkipSheets() As Variant
SkipSheets = Array("31.01." & InputYear, "28.02." & InputYear, "31.03." & InputYear, "30.04." & InputYear, "31.05." & InputYear, "30.06." & InputYear, "31.07." & InputYear, "31.08." & InputYear, "30.09." & InputYear, "31.10." & InputYear, "30.11." & InputYear, "31.12." & InputYear)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If Not (UBound(Filter(SkipSheets, ws.Name)) > -1) And ThisWorkbook.Worksheets.Count > 1 Then
ws.Delete
End If
Next ws
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This is another approach. Since you don't want to delete the last day of every month and looks like all the sheets are the same:
Option Explicit
Sub Delete_Sheets()
Dim ws As Worksheet, Month As Date, DontDelete As String, Yr As Integer
StartAgain:
On Error Resume Next
Yr = InputBox("Use YY format only.", "Which year to keep?", 18)
On Error GoTo 0
If Yr = 0 Then
MsgBox "You didn't enter a valid value. Please Try Again"
GoTo StartAgain
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name Like "??.??.??" And ThisWorkbook.Sheets.Count > 1 Then
ws.Delete
GoTo NextSheet
End If
Month = DateSerial(Yr, Mid(ws.Name, 4, 2), 1)
DontDelete = Format(Application.EoMonth(Month, 0), "dd.mm.yy")
If Not ws.Name = DontDelete Then
ws.Delete
End If
NextSheet:
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Edit: I've edited some code but it can't throw any error. Now it shouldn't delete some worksheet that it did. But there is no way you get an error.
Here is the result of the code:
I used vba to create a TOC for my workbook, but the code formatted my wsname to a number format and removed the leading zeros. Is there a way to modify the code to include the leading zeros in the links?
For example, each of my worksheets is titled with a number beginning with a zero such as "0303855" etc. When I ran this code, my TOC list was numbers without the zero ("303855" etc).
I used the following code:
Sub CreateTOC()
Dim wsA As Worksheet
Dim ws As Worksheet
Dim wsTOC As Worksheet
Dim lRow As Long
Dim rngList As Range
Dim lCalc As Long
Dim strTOC As String
Dim strCell As String
lCalc = Application.Calculation
On Error GoTo errHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
strTOC = "TOC"
strCell = "A1"
Set wsA = ActiveSheet
On Error Resume Next
Set wsTOC = Sheets(strTOC)
On Error GoTo errHandler
If wsTOC Is Nothing Then
Set wsTOC = Sheets.Add(Before:=Sheets(1))
wsTOC.Name = strTOC
Else
wsTOC.Cells.Clear
End If
With wsTOC
.Range("B1").Value = "Sheet Name"
lRow = 2
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible _
And ws.Name <> strTOC Then
.Cells(lRow, 2).Value = ws.Name
.Hyperlinks.Add _
Anchor:=.Cells(lRow, 2), _
Address:="", _
SubAddress:="'" & ws.Name _
& "'!" & strCell, _
ScreenTip:=ws.Name, _
TextToDisplay:=ws.Name
lRow = lRow + 1
End If
Next ws
Set rngList = .Cells(1, 2).CurrentRegion
rngList.EntireColumn.AutoFit
.Rows(1).Font.Bold = True
End With
Application.ScreenUpdating = True
wsTOC.Activate
wsTOC.Cells(1, 2).Activate
exitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = lCalc
Set rngList = Nothing
Set wsTOC = Nothing
Set ws = Nothing
Set wsA = Nothing
Exit Sub
errHandler:
MsgBox "Could not create list"
Resume exitHandler
End Sub
I'm trying to loop through sheets, and remove row entries that are not equal to sheet name.
I've if statements to ignore particular sheets.
It will only work on one sheet and won't loop through all.
Sub CleanRegionalSheets()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lngx As Long
With ws
For Each ws In ActiveWorkbook.Worksheets
If ActiveSheet.Name = "Raw Data" Then
ElseIf ActiveSheet.Name = "Building Status" Then
ElseIf ActiveSheet.Name = "Clean Data" Then
Else
For lngx = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
If Cells(lngx, "A").Value <> ActiveSheet.Name Then
Cells(lngx, "A").EntireRow.Delete Shift:=xlUp
End If
Next
End If
Next
End With
End Sub
Updated code, still not working:
Sub CleanRegionalSheets()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lngx As Long
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Raw Data" Then
ElseIf ws.Name = "Building Status" Then
ElseIf ws.Name = "Clean Data" Then
Else
For lngx = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
If Cells(lngx, "A").Value <> ws.Name Then
Cells(lngx, "A").EntireRow.Delete Shift:=xlUp
End If
Next
End If
Next
End Sub
You are missing the ws object. Try this (you also forgot to enable ScreenUpdate at the end):
Sub CleanRegionalSheets()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lngx As Long
For Each ws In ActiveWorkbook.Worksheets
Select Case ws.Name
Case "Raw Data", "Building Status", "Clean Data"
Case Else
With ws
For lngx = .Cells(.Rows.Count, "A").End(xlUp).Row To 3 Step -1
If .Cells(lngx, "A").Value <> .Name Then
.Rows(lngx).Delete Shift:=xlUp
End If
Next
End With
End Select
Next
Application.ScreenUpdating = True
End Sub