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.
Related
I would like to select multiple cells based on selection.
And here is my code:
Private Sub CommandButton1_Click()
Selection.EntireRow.Select
End Sub
I want to select the first four columns of rows in multiple cells, instead of the whole rows. How to achieve it?
this is my Excel worksheet
Select Rows of Non-Contiguous Range
Copy the codes into a standard module e.g. Module1.
In your command button click event use either of the procedure names in the following way:
Private Sub CommandButton1_Click()
selectRowsOfListObject
End Sub
or
Private Sub CommandButton1_Click()
selectRowsOfFirstFourColumns
End Sub
The first procedure will select only the rows of the selected cells in the first (structured) table in the ActiveSheet. Any cells outside the data of the table (DataBodyRange) will be ignored.
The second procedure will select all the row ranges of the selected cells in the first four columns, in the first four columns of the ActiveSheet. Any cells selected outside of the first four columns will be ignored
Each or both of the codes can be used with command buttons on any worksheet when they will refer to the worksheet 'containing' the command button.
If you want a command button on another worksheet to always refer to the first, you will rather have to create a reference to the first worksheet:
Instead of
Set ws = ActiveSheet
use e.g.
Set ws = wb.Worksheets("Sheet1")
To better understand the differences, you could add another command button for the second code and then test each of them.
The Code
Option Explicit
Sub selectRowsOfListObject()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ActiveSheet
Dim tbl As ListObject
Set tbl = ws.ListObjects(1)
If Selection.Worksheet.Name = ws.Name Then
If TypeName(Selection) = "Range" Then
Dim rng As Range
Set rng = Intersect(Selection, tbl.DataBodyRange)
If Not rng Is Nothing Then
Set rng = Intersect(rng.Rows.EntireRow, tbl.DataBodyRange.Rows)
End If
If Not rng Is Nothing Then
rng.Select
End If
End If
End If
End Sub
Sub selectRowsOfFirstFourColumns()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ActiveSheet
If Selection.Worksheet.Name = ws.Name Then
If TypeName(Selection) = "Range" Then
Dim rng As Range
Set rng = Intersect(Selection.Rows.EntireRow, _
ws.Columns(1).Resize(, 4))
If Not rng Is Nothing Then
rng.Select
End If
End If
End If
End Sub
Check this code:
Option Explicit
Sub Rows_Selection()
Dim rng As Range
Dim active_cells_adress, row_no As Variant
Dim final_selection_adress As String
Dim rng1 As String
Dim i As Integer
Selection.EntireRow.Select
Set rng = Selection
rng1 = rng.Address
final_selection_adress = ""
active_cells_adress = Split(rng1, "$")
For i = 2 To UBound(active_cells_adress)
row_no = Split(active_cells_adress(i), ",")
final_selection_adress = final_selection_adress + "A" & row_no(0) & ": D" & row_no(0) + ","
i = i + 1
Next
final_selection_adress = Left(final_selection_adress, Len(final_selection_adress) - 1)
Range(final_selection_adress).Select
End Sub
I would like to iterate through a list of sheets where the list is determined by a Range.
If I hard-code the list everything is fine.
what I'd like is to refer to a range that contains the sheet names (as it's variable).
Set mySheets = Sheets(Array("sheetOne", "sheetTwo", "sheetThree"))
With ActiveWorkbook
For Each ws In mySheets
'do the stuff here
Next ws
End With
so something like this:
Set mySheets = Sheets(Range("A1:E1"))
Any ideas?
This will work:
Sub MySub()
On Error Resume Next
Set mySheets = Sheets(removeEmpty(rangeToArray(Range("A1:E1"))))
If Err.Number = 9 Then
MsgBox "An error has occurred. Check if all sheet names are correct and retry.", vbCritical
Exit Sub
End If
On Error GoTo 0
With ActiveWorkbook
For Each ws In mySheets
'do the stuff here
Next ws
End With
End Sub
'This will transpose a Range into an Array()
Function rangeToArray(rng As Range) As Variant
rangeToArray = Application.Transpose(Application.Transpose(rng))
End Function
'This will remove empty values and duplicates
Function removeEmpty(arr As Variant) As Variant
Dim result As New Scripting.Dictionary
Dim element As Variant
For Each element In arr
If element <> "" And Not result.Exists(element) Then
result.Add element, Nothing
End If
Next
removeEmpty = result.Keys
End Function
This will load dynamically Sheets contained in your Range.
Edit
Added Function removeEmpty(...) to remove empty values and duplicates.
Note: the Function rangeToArray() is needed to return data in Array() format.
I hope this helps.
I would provide this solution, which does load the sheetnames into an array:
Notice that you have to transpose the Data if the values are ordered horizontal.
Public Sub test()
Dim mySheet As Variant
Dim sheet As Variant
mySheet = Application.Transpose(Tabelle1.Range("A1:E1").Value) 'load your Values into an Array, of course the range can also be dynamic
For Each sheet In mySheet
Debug.Print sheet 'print the sheet names, just for explaining purposes
'it may be necessary to use CStr(sheet) if you want to refer to a sheet like Thisworkbook.Worksheets(CStr(sheet))
'Do something
Next sheet
Erase mySheet 'delete the Array out of memory
End Sub
I demonstrate the code below which does what you want using an animated gif (click for better detail)
Option Explicit
Sub iterateSheets()
Dim sh As Worksheet, shName As String, i As Integer
i = 0
For Each sh In ThisWorkbook.Worksheets
shName = sh.Range("A1").Offset(i, 0)
Worksheets(shName).Range("A1").Offset(i, 0).Font.Color = vbRed
i = i + 1
Next
End Sub
you could do like this:
Sub DoThat()
Dim cell As Range
For Each cell In Range("A1:E1").SpecialCells(xlCellTypeConstants)
If Worksheets(cell.Value2) Is Nothing Then
MsgBox cell.Value2 & " is not a sheet name in " & ActiveWorkbook.Name & " workbook"
Else
With Worksheets(cell.Value2)
'do the stuff here
Debug.Print .Name
End With
End If
Next
End Sub
or the other way around:
Sub DoThatTheOtherWayAround()
Dim sht As Worksheet
For Each sht In Worksheets
If Not IsError(Application.Match(sht.Name, Range("A1:E1"), 0)) Then
'do the stuff here
Debug.Print sht.Name
End If
Next
End Sub
but in this latter case, you wouldn't be advised in case of any A1:E1 value not corresponding to actual sheet name
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
I found this VBA code on here that works great. I want the code to work on the other worksheets in the workbook. The code works great in Sheet 1 but I would like the code to work on Sheet 2, Sheet 3, etc. as well. I tried copying the code from the Sheet 1 Module and pasted it into Sheet 2, Sheet 3, etc. to see if the code works. The code doesn't quite work as I anticipated it. I think I need to do something with the Standard Module code so that the code will work properly.
Sheet 1 Module
Private Sub Worksheet_Calculate()
Dim rng As Range, c As Range
Dim rngToColor As Range
On Error GoTo ErrorHandler
Application.EnableEvents = False
'get only used part of the sheet
Set rng = Intersect(Me.UsedRange, Me.Range("A:Z"))
If rng Is Nothing Then GoTo ExitHere
For Each c In rng
'check if previous value of this cell not equal to current value
If cVals(c.Address) <> c.Text Then
'if so (they're not equal), remember this cell
c.ClearComments
c.AddComment Text:="Changed value from '" & cVals(c.Address) & "' to '" & c.Text & "'" & " on " & Format(Date, "mm-dd-yyyy") & " by " & Environ("UserName")
c.Interior.ColorIndex = 36
End If
'store current value of cell in dictionary (with key=cell address)
cVals(c.Address) = c.Text
Next c
ExitHere:
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Resume ExitHere
End Sub
ThisWorkbook Module
Private Sub Workbook_Open()
Application.Calculation = xlCalculationManual
Call populateDict
Application.Calculation = xlCalculationAutomatic
End Sub
Standard Module
Public cVals As New Dictionary
Sub populateDict()
Dim rng As Range, c As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = Intersect(.UsedRange, .Range("A:Z"))
For Each c In rng
cVals(c.Address) = c.Text
Next c
.Calculate
End With
End Sub
Edit: I took the standard module and revised it to:
Sub populateDict()
Dim rng As Range, c As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = Intersect(.UsedRange, .Range("A:Z"))
For Each c In rng
cVals(c.Address) = c.Text
Next c
.Calculate
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng = Intersect(.UsedRange, .Range("A:Z"))
For Each c In rng
cVals(c.Address) = c.Text
Next c
.Calculate
End With
End Sub
this edit almost does the trick, but not sure why code isn't working correctly
One way to do this is by placing the code in a separate module and then set your active sheet to a variable like this:
Sub myScript()
Dim wks As Worksheet
Set wks = ActiveSheet
MsgBox (wks.Range("A1"))
End Sub
If you call this with Sheet1 active it will return the value from Sheet1.
Another method is by passing in the sheet as a variable to the sub. Here is just one way to do this. Add a button to each sheet that you want the macro to run from. Double click each button in 'Design Mode' so that the VBA click event is opened in the editor. Add a call to your sub like this:
Private Sub CommandButton1_Click()
Call myScriptPass(ActiveSheet)
'Or you can qualify it like this
Call myScriptPass(Sheets(1))
End Sub
Now change your macro to this: (still located in a separate module)
Sub myScriptPass(wks As Worksheet)
MsgBox (wks.Range("A1"))
End Sub
EDIT
Using the code you added to your post you can change it to the following:
Public cVals As New Dictionary
Sub record()
Dim wks As Worksheet
Set wks = ActiveSheet
Dim rng As Range, c As Range
With wks
Set rng = Intersect(.UsedRange, .Range("A:Z"))
For Each c In rng
cVals(c.Address) = c.Text
Next c
.Calculate
End With
End Sub
Now, it will run for which ever sheet is active. So if you call the macro via button on Sheet1, then the code will run on Sheet1.
Loop from main program
Public cVals As New Dictionary
Sub myMainProgram()
Dim wks As Worksheet
'Loop thru each sheet in workbook example
For Each wks In Worksheets
Call record(wks)
Next wks
'Call subroutine for specific sheet example
Call record(sheets("sheet1"))
End Sub
Sub record(wks As Worksheet)
Dim rng As Range, c As Range
With wks
Set rng = Intersect(.UsedRange, .Range("A:Z"))
For Each c In rng
cVals(c.Address) = c.Text
Next c
.Calculate
End With
MsgBox ("Record macro was run on " & wks.Name & " worksheet.")
End Sub
I'm looking for a way to, instead of typing "ActiveCell.OffSet(1,1) over and over again in my vba code, define that as a variable, "x" and use that instead.
I have to use the dim command to do this but I"m not sure what the data type would be.
Suggestions?
When I test it using the code below I get Runtime Error 1004.
Private Sub CommandButton1_Click()
Dim i As Range
Set i = ActiveCell
ActiveSheet.Range(ActiveSheet.Range(i), ActiveSheet.Range(i).End(xlUp)).Select
End Sub
In response to your edit
Avoid the use of .Select/Activate and fully qualify your objects. INTERESTING READ
Your code can be written as
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim rng1 As Range, rng2 As Range
'~~> Change as applicable
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
Set rng1 = ws.Range("A10")
Set rng2 = .Range(rng1, rng1.End(xlUp))
With rng2
Debug.Print .Address
'
'~~> Do something with the range
'
End With
End With
End Sub
If you still want to know what was wrong with your code then see this.
You have already defined your range. You do not need to add ActiveSheet.Range() again. Your code can be written as
Private Sub CommandButton1_Click()
Dim i As Range
Set i = ActiveCell
ActiveSheet.Range(i, i.End(xlUp)).Select
End Sub
EDIT
Followup from comments
Was ActiveSheet.Range() actually problematic or just redundant? – user3033634 14 mins ago
It is problematic. The default property of a range object is .Value
Consider this example which will explain what went wrong with your code
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
Set rng = .Range("A1")
rng.Value = "Blah"
MsgBox rng '<~~ This will give you "Blah"
MsgBox rng.Value '<~~ This will give you "Blah"
MsgBox rng.Address '<~~ This will give you "$A$1"
MsgBox ws.Range(rng) '<~~ This will give you an error
'~~> Why? Becuase the above is evaluated to
'MsgBox ws.Range("Blah")
MsgBox ws.Range(rng.Address) '<~~ This will give you "Blah"
End With
End Sub
Dim x As Range
Set x = ActiveCell.OffSet(1,1)
EDIT: in response to your comment:
Private Sub CommandButton1_Click()
Dim i As Range
Set i = ActiveCell
ActiveSheet.Range(i, i.End(xlUp)).Select
End Sub