I want to hide rows 16 & 17 across the following tabs in my workbook:
Sheet6 (code name)
Sheet7 (code name)
Sheet8 (code name)
There has to be a better and more efficient way to write this code:
Sub Macro1()
Sheet6.Rows("16:17").Hidden = True
Sheet7.Rows("16:17").Hidden = True
Sheet8.Rows("16:17").Hidden = True
End Sub
When this code runs, its take longer than I thought it would.
Any help would be appreciated.
There are several ways; one that comes to mind is adding them to a dictionary and using For Each to loop through it.
I Adore ARRAYS - A Working Solution
Hide
Sub HideRows()
Dim arr As Variant
Dim i As Integer
arr = Array(Sheet6, Sheet7, Sheet8)
For i = LBound(arr) To UBound(arr)
arr(i).Rows("16:17").Hidden = True
Next
End Sub
Show All
Sub ShowRows()
Dim arr As Variant
Dim i As Integer
arr = Array(Sheet6, Sheet7, Sheet8)
For i = LBound(arr) To UBound(arr)
arr(i).Rows.Hidden = False
Next
End Sub
Toggle
Sub ToggleRows()
Dim arr As Variant
Dim i As Integer
arr = Array(Sheet6, Sheet7, Sheet8)
For i = LBound(arr) To UBound(arr)
arr(i).Rows("16:17").Hidden = Not arr(i).Rows("16:17").Hidden
Next
End Sub
Thanks to:
ProfoundlyOblivious for profoundly suggesting and providing the 'Toggle' version.
GMalc for providing the idea of yet another way (not ever seen by me) of using an Array.
Use an array of worksheets...
Dim ws As Worksheet
For Each ws In Worksheets(Array("Sheet6", "Sheet7", "Sheet8"))
ws.Rows("16:17").Hidden = True
Next
Related
The following code works:
Dim shts As Sheets
Set shts = Sheets(Array("Sheet1", "Sheet2"))
What I would like to do is add sheets that may be created in the future to the shts collection. The way I thought this would be accomplished involves using a loop where the sheet names are joined in a large string, making sure to obey the same formatting as in the example above. This is my non-working code:
Dim shts As Sheets
Dim wks() As Worksheet
Dim str As String
ReDim wks(0 To Sheets.Count)
Set wks(0) = Sheets(1)
str = wks(0).Name & """"
For i = 1 To UBound(wks)
Set wks(i) = Sheets(i)
str = str & ", """ & wks(i).Name & ""
Next i
Set shtsToProtect = Sheets(Array(str)) ' ERROR
[Run-time error '9': Subscript out of range]
I've tried several variants of the string argument, still no luck.
You can collect the subset sheets name into a string separated by given delimiter and then use Split() function to get an array out of it
Sub Test()
With ThisWorkbook
Dim shSubSetNames As String
Dim sh As Worksheet
For Each sh In .Worksheets
If sh.Name Like "Sheet*" Then ' change criteria as per your needs
shSubSetNames = shSubSetNames & sh.Name & "|"
End If
Next
If shSubSetNames <> vbNullString Then
shSubSetNames = Left$(shSubSetNames, Len(shSubSetNames) - 1)
Dim subSetShts As Sheets
Set shts = Sheets(Split(shSubSetNames, "|"))
shts.Select
End If
End With
End Sub
This is a solution to directly get to your goal, based on the code you wrote so far. You probably need to realize that having an array of worksheet names is not the same as only a string of names separated by commas. The latter is still just a string, not an array.
Sub Foo()
Dim i As Long
Dim shts() As String
ReDim shts(1 To ThisWorkbook.Worksheets.Count)
For i = 1 To ThisWorkbook.Worksheets.Count
shts(i) = ThisWorkbook.Worksheets(i).Name
Next i
Worksheets(shts).Select
End Sub
But as noted in the comments, there is something much simpler you can do:
Sub Bar()
ActiveWorkbook.Worksheets.Select
End Sub
I'm working on the macro below, that will allow the user to feed it multiple ranges, and it will restore the default for each cell in each range.
The problem comes when I try to loop through each of the ranges, I need to use a variant "vI as variant", that I need to convert into a range to be used in the next function.
How can I convert that vI variant to a range? (please keep in mind that ranges can be on a different sheets)
Sub restoreDefaults_cellByCell(ParamArray targetRanges())
Dim rI As Range, cellI As Range, vI As Variant
Dim sName As String
For Each vI In targetRanges
'Set rI = vI.Range 'This returns an error
For Each cellI In rI.cells
sName = NamedRange_getCellNamedRange(cellI, False)
If Not dNamesFromSelection.Exists(sName) Then
dNamesFromSelection.add sName, ""
End If
Next
Next
End sub
Perhaps using a For...Next loop with LBound/Ubound to iterate:
Sub restoreDefaults_cellByCell(ParamArray targetRanges())
Dim rI As Range, cellI As Range, i As Long
Dim sName As String
For i = LBound(targetRanges) to Ubound(targetRanges)
If TypeOf targetRanges(i) Is Range Then
Set rI = targetRanges(i)
For Each cellI In rI.cells
sName = NamedRange_getCellNamedRange(cellI, False)
If Not dNamesFromSelection.Exists(sName) Then
dNamesFromSelection.add sName, ""
End If
Next
End If
Next
End Sub
Or just:
If TypeOf vI is Range Then
Set rI = vI
End If
though I would suggest using a For...Next loop to iterate over arrays instead of a For Each loop.
It seems I needed to loop 2 times, with v1 and v2, even though the tested named range was a named range containing 5 separate cells.
I gues loop once for range, look twice for area, and only them I can loop through cells.
Conversion is succesfull this way.
Sub restoreDefaults_cellByCell_MAIN_TEST()
restoreDefaults_cellByCell_MAIN Range("'Global Inputs'!SID_lead_required")
End Sub
Sub restoreDefaults_cellByCell_MAIN(ParamArray targetRanges())
setProgramAlertsOff
restoreDefaults_cellByCell targetRanges
setProgramAlertsOn
End Sub
Sub restoreDefaults_cellByCell(ParamArray targetRanges())
Dim rI As Range, cellI As Range, v1, v2
Dim sName As String, dName As Variant, sFormula As String
Dim dNamesFromSelection As New Scripting.Dictionary
Dim arrDefaults(), dHeaders As New Scripting.Dictionary, dDefaults As New Scripting.Dictionary
Dim rowI As Variant
Dim LO As ListObject
For Each v1 In targetRanges
For Each v2 In v1
Set rI = v2
For Each cellI In rI.cells
sName = NamedRange_getCellNamedRange(cellI, False)
If Not dNamesFromSelection.Exists(sName) Then
dNamesFromSelection.add sName, ""
End If
Next
Next
Next
End Sub
I have the following code where I want to delete the sheets, I noticed that if they do not exist I get an error, how can I validate and delete only if they exist?
I also noticed I get a deleting warning for every single sheet, any way I can prevent from seeing that warning?
Sub delete_hours()
Worksheets("8am").Delete
Worksheets("9am").Delete
Worksheets("10am").Delete
Worksheets("11am").Delete
Worksheets("12pm").Delete
Worksheets("1pm").Delete
Worksheets("2pm").Delete
Worksheets("3pm").Delete
Worksheets("4pm").Delete
Worksheets("5pm").Delete
Worksheets("6pm").Delete
End Sub
if you find a better way to do this let me know.
Thanks all,
Delete Existing Worksheets
You need the first three procedures: TESTdeleteWorksheetsFromList calls deleteWorksheetsFromList which calls getWorksheetNames.
TESTgetWorksheetNames just tests getWorksheetNames.
It surely can be done much simpler, but I had this idea...
The Flow (deleteWorksheetsFromList)
The values from the DeleteList are written to the delNames array.
All worksheet names are written to the allNames array.
Application.Match is 'applied' to both arrays resulting in Matches array.
Matches array is looped through to write 'matches' to the 'beginning' of delNames array.
delNames array is resized to the number of found matches.
delNames array is used to delete the worksheets in one go.
The Code
Option Explicit
Sub TESTdeleteWorksheetsFromList()
Const DeleteList As String _
= "8am,9am,10am,11am,12pm,1pm,2pm,3pm,4pm,5pm,6pm"
Dim wb As Workbook: Set wb = ThisWorkbook
deleteWorksheetsFromList wb, DeleteList
End Sub
Sub deleteWorksheetsFromList( _
wb As Workbook, _
ByVal DeleteList As String, _
Optional ByVal Delimiter As String = ",")
Dim delNames() As String: delNames = Split(DeleteList, Delimiter)
Dim allNames() As String: allNames = getWorksheetNames(wb)
Dim Matches As Variant: Matches = Application.Match(allNames, delNames, 0)
Dim i As Long
Dim k As Long
For i = 1 To UBound(Matches)
If IsNumeric(Matches(i)) Then
delNames(k) = delNames(Matches(i) - 1)
k = k + 1
End If
Next i
If k > 0 And k < wb.Sheets.Count Then
ReDim Preserve delNames(0 To k - 1)
Application.DisplayAlerts = False
wb.Worksheets(delNames).Delete
Application.DisplayAlerts = False
End If
End Sub
Function getWorksheetNames(wb As Workbook) As Variant
Dim wsCount As Long
wsCount = wb.Worksheets.Count
If wsCount > 0 Then
Dim wsNames() As String
ReDim wsNames(0 To wsCount - 1)
Dim ws As Worksheet
Dim n As Long
For Each ws In wb.Worksheets
wsNames(n) = ws.Name
n = n + 1
Next ws
getWorksheetNames = wsNames
End If
End Function
Sub TESTgetWorksheetNames()
Debug.Print Join(getWorksheetNames(ThisWorkbook), vbLf)
End Sub
You can use the following code prior to attempting deletions:
On Error Resume Next
When you are done:
On Error goto 0
That's the quick and dirty solution. You should also use a loop instead of repeating the same code:
for i=8 to 12
sheetname = i & "am"
sheets.delete(sheetname)
next
I need to classify each row of a range accordingly with another range. The script works just fine. But it takes too much time even if it has no more than 300 rows. E.g. 298 rows take more than 2 minutes.
In order to achieve the classification, the script was built with a for each loop inside another one. All is done in the same worksheet called WSSeg. I tried to use all the good practices that I know of.
Option Explicit
Sub Input_Classification()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim TBLClassification As ListObject
Dim TBLReference As ListObject
Dim rClassificationCell As Range
Dim rClassification As Range
Dim rReferenceCell As Range
Dim rReference As Range
Set TBLClassification = WSSeg.ListObjects("TBClass")
Set rClassification = TBL.ListColumns(4).DataBodyRange
Set TBLReference = WSSeg.ListObjects("TBResumo")
Set rReference = TBL.ListColumns(4).DataBodyRange
For Each rClassificationCell In rClassification
For Each rReferenceCell In rReference
If rClassificationCell.Offset(0, -1).Value <= rReferenceCell.Value Then
rClassificationCell.Value = rReferenceCell.Value
End If
Next rReferenceCell
Next rClassificationCell
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I expect the run time code to be shorter. I don't know if I have to use another logic system. Thanks in advance.
Tried to modify the code, it takes only 0.04 Secs with two tables of around 500 rows.
Tried to keep the replacement logic same as the original, But may please check the same, as i am little confused about the same. If find otherwise, please modify them to your need. Also Could not understand the what is TBL in cases with both the tables and assumed the obvious.
Option Explicit
Sub Input_Classification()
Dim WSSeg As Worksheet
Dim TBLClassification As ListObject
Dim TBLReference As ListObject
Dim rClassification As Range
Dim SrcArr As Variant, TrgArr As Variant, SrcCel As Variant
Dim i As Long, Tm As Double
Set WSSeg = ThisWorkbook.Sheets("Sheet1")
Tm = Timer
Set TBLClassification = WSSeg.ListObjects("TBClass")
Set rClassification = TBLClassification.ListColumns(3).DataBodyRange.Resize(TBLClassification.DataBodyRange.Rows.Count, 2)
TrgArr = rClassification.Value
Set TBLReference = WSSeg.ListObjects("TBResumo")
SrcArr = TBLReference.ListColumns(4).DataBodyRange.Value
For i = 1 To UBound(TrgArr, 1)
For Each SrcCel In SrcArr
If TrgArr(i, 1) <= SrcCel Then
TrgArr(i, 2) = SrcCel
End If
Next SrcCel
Next i
rClassification.Value = TrgArr
Debug.Print "Seconds taken " & Timer - Tm
End Sub
Since I personally don't prefer to keep calculations, event processing and screen updating off (in normal cases) i haven't added that standard lines. However you may use these standard techniques, depending on the working file condition.
I'm currently trying to trace the dependencies of a complex set of Excel spreadsheets. My ideal end goal would be a tree structure, starting with my first spreadsheet. However, I don't want to include all of the dependencies of the child spreadsheets, just the ones of the cells referenced by the original spreadsheet. For example:
In cell A1 of my first workbook:
somebook.xls!Sheet1!C2
I want to look at cell C2 in sheet 1 of somebook.xls for its (external) dependencies, and then recurse.
At the moment I'm using LinkInfo to get a list of external dependencies, searching using Find, and I'm struggling with vbscript's primitive regex capabilities to try and extract the address out of the cells I find. This is not a brilliant way of doing things.
Does anyone know if Excel will tell you which cells in an external spreadsheet are being referenced? If not, any other tools that might help?
Thanks.
This answer is based off Bill Manville's macro from many years back. The macro still works, but I broke it out into functions allowing for more flexibility and reusability. The main addition by me is the ability to find external dependencies only, and the extension to both precedents and dependents. I also added a call to a custom macro called unhideAll; this was necessary for me as dependencies were not being found in hidden worksheets.
'Module for examining depedencies to/from a sheet from/to other sheets
Option Explicit
Sub showExternalDependents()
Dim deps As Collection
Set deps = findExternalDependents(ActiveCell)
Call showDents(deps, True, "External Dependents: ")
End Sub
Sub showExternalPrecedents()
Dim precs As Collection
Set precs = findExternalPrecedents(ActiveCell)
Call showDents(precs, True, "External Precedents: ")
End Sub
'external determines whether or not to print out the absolute address including workbook & worksheet
Sub showDents(dents As Collection, external As Boolean, header As String)
Dim dent As Variant
Dim stMsg As String
stMsg = ""
For Each dent In dents
stMsg = stMsg & vbNewLine & dent.Address(external:=external)
Next dent
MsgBox header & stMsg
End Sub
Function findPrecedents(rng As Range) As Collection
Set findPrecedents = findDents(rng, True)
End Function
Function findDependents(rng As Range) As Collection
Set findDependents = findDents(rng, False)
End Function
Function findExternalPrecedents(rng As Range) As Collection
Set findExternalPrecedents = findExternalDents(rng, True)
End Function
Function findExternalDependents(rng As Range) As Collection
Set findExternalDependents = findExternalDents(rng, False)
End Function
'Gives back only the dependencies that are not on the same sheet as rng
Function findExternalDents(rng As Range, precDir As Boolean) As Collection
Dim dents As New Collection
Dim dent As Range
Dim d As Variant
Dim ws As Worksheet
Set ws = rng.Worksheet
For Each d In findDents(rng, precDir)
Set dent = d
With dent
If Not (.Worksheet.Name = ws.Name And .Worksheet.Parent.Name = ws.Parent.Name) Then _
dents.Add Item:=dent
End With
Next d
Set findExternalDents = dents
End Function
'this procedure finds the cells which are the direct precedents/dependents of the active cell
'If precDir is true, then we look for precedents, else we look for dependents
Function findDents(rng As Range, precDir As Boolean) As Collection
'Need to unhide sheets for external dependencies or the navigate arrow won't work
Call mUnhideAll
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim dents As New Collection
Dim bNewArrow As Boolean
'Appliciation.ScreenUpdating = False
If precDir Then
ActiveCell.showPrecedents
Else
ActiveCell.ShowDependents
End If
Set rLast = rng
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=precDir, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
dents.Add Item:=Selection
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
Set findDents = dents
End Function
Sub mUnhideAll()
'
' mUnhideAll Macro
'
' Unhide All
Dim ws As Worksheet
For Each ws In Worksheets
ws.Visible = True
Next
'Sheets("Sprint Schedule Worksheet").Visible = False
End Sub
Excel's built in support, as you're finding, is limited and can be extremely frustrating.
In my experience, I've found a couple of tools from http://www.aivosto.com/ to be useful; Visustin v6 is especially useful for code related auditting/processing.
Here's a simpler version of Colm Bhandal's findDents and findExternalDents. It assumes all worksheets were made visible and arrows were cleared before use.
Function findDents(rCell As Range, bPrec As Boolean) As Collection
'Return all direct precedents (bPrec=True) or dependents (bPrec=False) of rCell
Dim sAddr As String, nLink As Integer, nArrow As Integer
Const bAbs As Boolean = False, bExt As Boolean = True
Set findDents = New Collection
If bPrec Then
rCell.showPrecedents ' even if rCell has no formula
Else
rCell.showDependents
End If
On Error Resume Next ' ignore errors
sAddr = rCell.Address(bAbs, bAbs, xlA1, bExt)
nArrow = 1
Do
nLink = 1
Do
rCell.NavigateArrow bPrec, nArrow, nLink
If ActiveCell.Address(bAbs, bAbs, xlA1, bExt) = sAddr Then Exit Do
findDents.Add Selection ' possibly more than one cell
nLink = nLink + 1
Loop
If nLink = 1 Then Exit Do
nArrow = nArrow + 1
Loop
On Error GoTo 0
If bPrec Then
rCell.showPrecedents Remove:=True
Else
rCell.showDependents Remove:=True
End If
End Function
Function findExternalDents(rCell As Range, bPrec As Boolean) As Collection
'Return ...Dents that are NOT in the same workbook and worksheet as rCell
Dim rDent As Range, wsName As String, wbName As String
With rCell.Worksheet: wsName = .Name: wbName = .Parent.Name: End With
Set findExternalDents = New Collection
For Each rDent In findDents(rCell, bPrec)
If rDent.Worksheet.Name <> wsName Or rDent.Worksheet.Parent.Name <> wbName Then findExternalDents.Add Item:=rDent
Next rDent
End Function
You might want to modify this to use a SortedList instead of a Collection. In that case, change
findDents.Add Selection
to
findDents.Add Selection.Address(bAbs, bAbs, xlA1, bExt), Null