I have this function that removes the allow edit range from Excel, but I keep on getting an error indicating that method delete of object alloweditrange failed
Sub RemoveUserEditRange()
Dim ws As Worksheet, rng As Range, aer As AllowEditRange
Set ws = ThisWorkbook.Sheets("Protection")
ws.Unprotect
For Each aer In ws.Protection.AllowEditRanges
aer.Delete
Next
End Sub
Are you sure you have that range?
Try this
Sub RemoveUserEditRange()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Protection")
With ws
.Unprotect
With .Protection
If .AllowEditRanges.Count = 0 Then
MsgBox "Nothing to delete"
Else
'~~> Check if there is actually a range
Do While .AllowEditRanges.Count > 0
.AllowEditRanges(1).Delete
Loop
End If
End With
.Protect '<~~ ???
End With
End Sub
Try selecting your sheet before the loop :
ws.Select
Related
I am working on a project to clean up a couple hundred excel sheets for an specific import spec. The import process errors out if any rows have a specific value blank, so I'm looking to find the best way to delete all rows in the entire workbook if column C in that row is empty. I found this simple VBA code that works on the active sheet, but I need it to loop through all sheets in the workbook. Any suggestions on a better process so I don't have to run it >100 times?
Sub DelBlankRows()
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
Delete the Rows of a Column's Blanks
Option Explicit
Sub DelRowsOfColumnBlanksTEST()
Const wsCol As Variant = "C" ' or 3
'Const wsCol As String = "C"
'Const wsCol As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In wb.Worksheets
DelRowsOfColumnBlanks ws, wsCol
Next ws
Application.ScreenUpdating = True
End Sub
Sub DelRowsOfColumnBlanks( _
ByVal ws As Worksheet, _
ByVal WorksheetColumnID As Variant)
If ws Is Nothing Then Exit Sub ' no worksheet
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
Dim urg As Range: Set urg = ws.UsedRange
If urg.Rows.Count = 1 Then Exit Sub ' only one row
On Error Resume Next
Dim crg As Range: Set crg = ws.Columns(WorksheetColumnID)
On Error GoTo 0
If crg Is Nothing Then Exit Sub ' invalid Worksheet Column ID
Dim tcrg As Range: Set tcrg = Intersect(urg, crg)
' ... is only the same as 'Set tcrg = urg.Columns(WorkhseetColumnID)',...
' ... if the first column of the used range is column 'A'.
If tcrg Is Nothing Then Exit Sub ' no intersection
Dim drg As Range: Set drg = tcrg.Resize(tcrg.Rows.Count - 1).Offset(1)
tcrg.AutoFilter 1, "=" ' ... covers blanks: 'Empty', "=""""", "'"... etc.
' Note that although it contains the word 'Blanks',...
' ... 'SpecialCells(xlCellTypeBlanks)' only covers 'Empty'.
On Error Resume Next
Dim spcrg As Range: Set spcrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not spcrg Is Nothing Then
spcrg.EntireRow.Delete
'Else
' no 'visible' cells (to delete)
End If
ws.AutoFilterMode = False
End Sub
Option Explicit
Sub CleanWorkbook()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
DeleteRowsOfEmptyColumn sh, "C"
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub DeleteRowsOfEmptyColumn(sh As Worksheet, col as string)
Dim rowsToDelete As New Collection
Dim cell
For Each cell In Intersect(sh.UsedRange, sh.Columns(col))
If cell.Value = "" Then
rowsToDelete.Add cell.Row
End If
Next
Dim i As Integer
For i = rowsToDelete.Count To 1 Step -1
sh.Rows(rowsToDelete(i)).Delete
Next
End Sub
I've put a very basic error trap for any sheets with no values in C. You may need to improve this yourself.
Edit: Updated error trap
Sub DelBlankRows()
Dim sh As Worksheet
Application.ScreenUpdating = False
On Error GoTo Handle
For Each sh In ThisWorkbook.Worksheets
sh.Activate
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Cont:
Next sh
Application.ScreenUpdating = True
Exit Sub
Handle:
If Err.Number = 1004 Then Resume Cont
End Sub
Working on a macro that will go to the first sheet. I was using:
Sub GoToFirstSheet()
On Error Resume Next
Sheets(1).Select
End Sub
However, if sheet 1 is hidden, this wont work. How can I incorporate a way to go to the first sheet that isn't hidden?
Something like this?
Option Explicit
Sub GoToFirstSheet()
Dim i As Long
For i = 1 To ThisWorkbook.Sheets.Count
On Error Resume Next
Sheets(i).Activate
If Err.Number = 0 Then Exit For
Next i
End Sub
This should do it:
Option Explicit
Sub GoToFirstSheet()
Dim ws As Worksheet 'declare a worksheet variable
'loop through all the worksheets in the workbook
For Each ws In ThisWorkbook.Worksheets
'If the sheet is not hidden
If ws.Visible = xlSheetVisible Then
ws.Select 'select it
Exit For 'exit the loop
End If
Next ws
End Sub
Hi everyone i made a button on excel using VBA modules,The code works on the active sheet but what im looking for is to be applied to more sheets, not just the active sheet where the button is placed.
Sub Botón1_Haga_clic_en()
Call Worksheet_Calculate
End Sub
'apply cells colors from single-cell formula dependencies/links
Private Sub Worksheet_Calculate()
Dim Cel As Range
Dim RefCel As Range
On Error Resume Next
For Each Cel In ActiveSheet.UsedRange
If Cel.HasFormula Then
Set RefCel = Evaluate(Mid(Cel.Formula, 2))
Cel.Interior.Color = RefCel.Interior.Color
End If
Next Cel
End Sub
Try the code below :
Option Explicit
Sub Botón1_Haga_clic_en()
Dim wsName As String
Dim ws As Worksheet
wsName = ActiveSheet.Name
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name Like wsName Then '<-- is worksheet's name doesn't equal the ActiveSheet's
ApplyCellColors ws ' <-- call you Sub, with the worksheet object
End If
Next ws
End Sub
'=======================================================================
'apply cells colors from single-cell formula dependencies/links
Private Sub ApplyCellColors(ws As Worksheet)
Dim Cel As Range
Dim RefCel As Range
On Error Resume Next
For Each Cel In ws.UsedRange
If Cel.HasFormula Then
Set RefCel = Evaluate(Mid(Cel.Formula, 2))
Cel.Interior.Color = RefCel.Interior.Color
End If
Next Cel
End Sub
Your problem can be translated to something like How to loop over all sheets and ignore one of them?
This is a good way to do it:
Option Explicit
Option Private Module
Public Sub TestMe()
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If wks.name = "main" Then
Debug.Print "Do nothing here, this is the active sheet's name"
Else
Debug.Print wks.name
End If
Next wks
End Sub
Pretty sure, that you should be able to fit it in your code.
I am looking for a way with VBA in excel to loop through spreadsheet. I found a lot of sites with recommendations on using a range function, but nothing specific enough that has solve the issues that I have. Macro will only work on current tab. It will not loop through.
Sub UpdateAll()
'
' UpdateAll Macro
'
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call Update_OI
Next ws
End Sub
Sub Update_OI()
'
' Update_OI Macro
Dim rng As Range
For Colx = 3 To 81
Cells(10, Colx).Select
If ActiveCell.Offset(-8, 0) = "X" Then GoTo 4
If ActiveCell.Offset(-3, 0) = 0 Then GoTo 4
If ActiveCell.Value = vbNullString Then GoTo 4
If ActiveCell.Value <> vbNullString Then GoTo 1
1
goalvalue = Cells(70, Colx).Value
Range(Cells(69, Colx), Cells(69, Colx)).GoalSeek Goal:=goalvalue, ChangingCell:=Range(Cells(10, Colx), Cells(10, Colx))
4
Next Colx
End Sub
You can pass the sheet object to Update_OI, and try not to use Select/Activate - you can almost always avoid that, and doing so will make your code more robust.
Sub UpdateAll()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Update_OI ws
Next ws
End Sub
Sub Update_OI(ws as Worksheet)
Dim rng As Range, Colx As Long
For Colx = 3 To 81
Set rng = ws.Cells(10, Colx)
If rng.Offset(-8, 0).Value <> "X" And _
rng.Offset(-3, 0).Value <> 0 And _
Len(rng.Value) > 0 Then
goalvalue = ws.Cells(70, Colx).Value
ws.Cells(69, Colx).GoalSeek Goal:=goalvalue, _
ChangingCell:=ws.Cells(10, Colx)
End If
Next Colx
End Sub
Change your update all as below. It should work now.
Sub UpdateAll()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Select
Call Update_OI
Next ws
End Sub
Below code works
Public Sub main()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Cells(1, 2).Value = 11111
Next ws
End Sub
Try changing
Dim ws As Worksheet For Each ws In ActiveWorkbook.Worksheets
Call Update_OI
Next ws
To
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call Update_OI
Next ws
Or was it just copy paste formating problem. In this case I will remove my answer as it si no answer :).
I would like to have a code that unchecks all checkboxes named "CheckBox1" for all sheets across the workbook. My current code unfortunately doesn't work, and I'm not sure why - it only works for the active sheet.
Private Sub CommandButton1_Click()
Dim Sheet As Worksheet
For Each Sheet In ThisWorkbook.Worksheets
Select Case CheckBox1.Value
Case True: CheckBox1.Value = False
End Select
Next
End Sub
This code iterates through all sheets (except sheets named Sheet100 and OtherSheet) and unchecks all your ActiveX checkboxes named CheckBox1
Sub uncheck_boxes()
Dim ws As Worksheet
Dim xbox As OLEObject
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet100" And ws.Name <> "OtherSheet" Then
For Each xbox In ws.OLEObjects
ws.OLEObjects("CheckBox1").Object.Value = False
Next
End If
Next
End Sub
To uncheck all ActiveX checkboxes in all sheets disregarding the names used
Sub uncheck_all_ActiveX_checkboxes()
Dim ws As Worksheet
Dim xbox As OLEObject
For Each ws In ThisWorkbook.Worksheets
For Each xbox In ws.OLEObjects
ws.OLEObjects(xbox.Name).Object.Value = False
Next
Next
End Sub
To uncheck all Form Control checkboxes on a spreadsheet use
Sub uncheck_forms_checkboxes()
Dim ws As Worksheet
Dim xshape As Shape
For Each ws In ThisWorkbook.Worksheets
For Each xshape In ws.Shapes
If xshape.Type = msoFormControl Then
xshape.ControlFormat.Value = False
End If
Next
Next
End Sub
[edited following comments]
Try this:
Sub test()
Dim ws As Excel.Worksheet
Dim s As Object
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Definitions" And ws.Name <> "fx" Then
Set s = Nothing
On Error Resume Next
Set s = ws.OLEObjects("CheckBox1")
On Error GoTo 0
If Not s Is Nothing Then
s.Object.Value = False
End If
End If
Next ws
End Sub
This is a global function (it doesn't belong to a particular sheet), but you can put it inside CommandButton1_Click() if you want.
You might not need the error blocking if your sheets (other than Definitions and fx) always contain CheckBox1. Alternatively remove that if statement.