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
Related
Can you you help to combine this 2 code and remove all unnecessary lines to avoid long running time, and I tried to combine it but I get Run time error #9
STEP 1 (Code# 1)
Sub STEP1()
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
STEP 2 (Code# 2)
Sub STEP_2()
Dim ws As Worksheet
For Each ws In Sheets
ws.Cells(1, 1).EntireColumn.Delete
Next ws
Sheets("x_ 659358").Select
Rows("2:3").Select
Selection.Delete Shift:=xlUp
Sheets("x_682549 (2)").Select
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Dim headers() As Variant
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
headers() = Array("sku", "barcode", "active", "price")
For Each ws In wb.Sheets
With ws
.Rows(1).Value = ""
For i = LBound(headers()) To UBound(headers())
.Cells(1, 1 + i).Value = headers(i)
Next i
.Rows(1).Font.Bold = True
End With
Next ws
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.SaveAs xDir & "\" & xWs.Name, xlCSV
Next
End Sub
I have tried to combine but always get stucked
Sub STEP1()
' your code...
Call STEP_2() ' <----
End Sub
Sub STEP_2()
' your code...
End Sub
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
I'm trying to delete any sheet with a title that is not "PR11_P3".
In the remaining sheet there is a table "PR11_P3_Tabell" which is by now always filtered or rather sorted somehow and this is what I'm trying to restore with .ShowAllData.
Sub DeleteSheetRestoreSort()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "PR11_P3" Then
ws.Delete
Then
ActiveSheet.ShowAllData
End If
Next ws
End Sub
There is no guarantee that ActiveSheet is the sheet you want to clear. Use ws instead.
Sub DeleteSheetRestoreSort()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "PR11_P3" Then
ws.Delete
Else
If ws.filtermode then
ws.ShowAllData
End If
End If
Next ws
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I need to copy a sheet and rename based on cell value.
How do I create a non-dynamic copy? I need it to be more of a screenshot so all values stay the same. The idea being I can make many still copies and edit the main sheet.
The code I have makes a dynamic copy that changes when the main does.
How would I edit this code so it is gives still image copies?
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Set wh = Worksheets(ActiveSheet.Name)
ActiveSheet.Copy After:=Worksheets(Sheets.Count)
If wh.Range("W13").Value <> "" Then
ActiveSheet.Name = wh.Range("W13").Value
End If
wh.Activate
End Sub
Two people have suggested copy and pasting special values. This adds an operation of moving the data to your clipboard, which is an external buffer outside of Excel. This has the side effect of clearing the users clipboard. If they had copied something it would now be lost.
This is faster and doesn't destroy the clipboard:
Private Sub CommandButton3_Click()
Dim oldSheet As Worksheet
Set oldSheet = ActiveSheet
oldSheet.Copy After:=Worksheets(Sheets.Count)
Dim newSheet As Worksheet
Set newSheet = ActiveSheet
If oldSheet.Range("W13").Value <> "" Then
newSheet.Name = oldSheet.Range("W13").Value
End If
With newSheet.UsedRange
.Value = .Value
End With
End Sub
Addition of these lines will help:
With ActiveSheet
.UsedRange.Copy
.UsedRange.PasteSpecial xlPasteValues
End With
You can make use of the Range.Pastespecial property of Range Class
Full Code:
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Set ws = Worksheets(ActiveSheet.Name)
ws.Copy After:=Worksheets(Sheets.Count)
With ActiveSheet
.UsedRange.Copy
.UsedRange.PasteSpecial xlPasteValues
End With
If ws.Range("W13").Value <> "" Then
ActiveSheet.Name = ws.Range("W13").Value
End If
ws.Activate
End Sub
All you are missing is to copy data and paste them as values
Private Sub CommandButton3_Click()
Dim ws As Worksheet
Set wh = Worksheets(ActiveSheet.Name)
ActiveSheet.Copy After:=Worksheets(Sheets.Count)
If wh.Range("W13").Value <> "" Then
ActiveSheet.Name = wh.Range("W13").Value
End If
With ActiveSheet.Cells
.Copy
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("A1").Select
End With
wh.Activate
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