I created a script that hides rows in my active sheet if the row has a "-". I would like to apply this to other sheets (i.e. Sheet-ABC, Sheet-DEF) as well. I tried using an array, but was unsuccessful.
Any help is appreciated.
Sub hideRows()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Dim cell, cell2 As Range, hRws As Range
Set Rng = Sheet15.Range("A52:L359")
Rng.EntireRow.Hidden = False
For Each cell In Range("A52:L359").SpecialCells(xlBlanks)
If cell = "-" And cell.Offset(-1, 0) = "-" Then
If hRws Is Nothing Then
Set hRws = Range(cell, cell.Offset(1, 0))
Else
Set hRws = Union(hRws, Range(cell, cell.Offset(1, 0)))
End If
End If
Next
If Not hRws Is Nothing Then hRws.EntireRow.Hidden = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
You can call your hideRows() method inside a for-loop. Something like this:
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
hideRows()
Next
Related
I have a multidimensional power pivot table in sheet "Template2" created by a data model. I want VBA which circles through the slicer "Slicer_Sublot_code" and for each selection a new sheet to be created named after the slicer's selected item and the filtered pivot table to be pasted in it maintaining only values and format.
So far I have managed to create the empty sheets named by the slicer's items (the VBA reads the names from a range F2:F10 instead of taking them from the slicer which would be ideal):
Sub AddSheets()
Dim xRg As Excel.Range
Dim wSh As Excel.Worksheet
Dim wBk As Excel.Workbook
Set wSh = ActiveSheet
Set wBk = ActiveWorkbook
Application.ScreenUpdating = False
For Each xRg In wSh.Range("F2:F10")
With wBk
.Sheets.Add after:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRg.Value
If Err.Number = 1004 Then
Debug.Print xRg.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
Next xRg
Application.ScreenUpdating = True
End Sub
I have also managed to do the copy/paste of the pivot table (keeping values and format) on a new sheet but the name is pre-defined "Report":
Sub PivotTablePasteSpecial()
Dim SourcePivottable As PivotTable
Dim DestinationRange As Range
Dim aCell As Range
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set SourcePivottable = Worksheets("Template2").PivotTables(1)
Set DestinationRange = Worksheets("Report").Range("A1")
' Copy TableRange1
SourcePivottable.TableRange1.Copy
With DestinationRange.Offset( _
SourcePivottable.TableRange1.Row - SourcePivottable.TableRange2.Row, 0)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
End With
' Copy everything above TableRange1 cell-by-cell
For Each aCell In SourcePivottable.TableRange2.Cells
If Not Intersect(aCell, SourcePivottable.TableRange1) Is Nothing Then Exit For
aCell.Copy
With DestinationRange.Offset( _
aCell.Row - SourcePivottable.TableRange2.Row, _
aCell.Column - SourcePivottable.TableRange2.Column)
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
Next aCell
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
How can I combine the 2 in order to achieve the desired outcome described in the first paragraph?
I am using the below code to retain sheets that I need and delete the rest.
Sub DeleteSheets1()
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Sheet1" And xWs.Name <> "Sheet2" Then
xWs.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have around 6 sheets that I want to retain. I need help modifying the syntax to accommodate multiple sheets. Something like below
if xWs.Name <> ("sheet1", "sheet2"....) then xws.delete
Here arr is an array of the sheets to retain:
Sub DeleteSheets1()
Dim xWs As Worksheet, s As String, i As Long
Dim skp As Boolean
arr = Array("Sheet1", "Sheet2", "Sheet3")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
n = ActiveWorkbook.Worksheets.Count
For i = n To 1 Step -1
s = Sheets(i).Name
skp = False
For Each a In arr
If s = a Then skp = True
Next a
If Not skp Then Sheets(i).Delete
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
The valueInArray boolean function could work the code easier:
Public Function valueInArray(myValue As Variant, myArray As Variant) As Boolean
Dim cnt As Long
For cnt = LBound(myArray) To UBound(myArray)
If CStr(myValue) = CStr(myArray(cnt)) Then
valueInArray = True
Exit Function
End If
Next cnt
End Function
Sub DeleteSheets()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim cnt As Long
cnt = Worksheets.Count
Dim arrWks As Variant
arrWks = Array("Sheet1", "Sheet2", "Sheet3")
For cnt = Worksheets.Count To 1
If Not valueInArray(Worksheets(cnt).Name, arrWks) Then
Worksheets(cnt).Delete
End If
Next cnt
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
The valueInArray function gets value to search for myValue and array where to search for this value myArray. It loops through all elements of the array and if it finds the same String of the passed value, it returns True and exits. If it is not found, it returns False, as this is the default.
Another approach
Sub Test()
Dim ws As Worksheet
Dim arr As Variant
arr = Array("Sheet1", "Sheet2", "Sheet3")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If Not IsNumeric(Application.Match(ws.Name, arr, 0)) Then ws.Delete
Next ws
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Ok, this one doesn't quite fulfil the requirement of an array, but it's another way of using a single loop.
It looks for an occurrence of the sheet name in the RetainSheets string. Each sheet name is surrounded by | just in case there's a sheet name within a sheet name eet1Sh as an example.
The code will not attempt to delete the last worksheet in the workbook either.
Sub Test()
Dim wrkSht As Worksheet
Dim RetainSheets As String
RetainSheets = "|Sheet1|Sheet2|"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each wrkSht In Worksheets
If InStr(RetainSheets, wrkSht.Name) = 0 And Worksheets.Count > 1 Then
wrkSht.Delete
End If
Next wrkSht
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I have written some code to hide and unhide sheets by changing values in the 1st worksheet, how can I make all sheets visible except for the first 2 sheets?
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("H5").Value = "ADMIN" Then
Sheets(2).Visible = True
Sheets(2).Activate
Else
Sheets(2).Visible = xlVeryHidden
End If
If Range("G8").Value = True And Range("H5").Value = "" Then
Sheets(3).Visible = True 'I want to visible all sheets except first two sheets.
Sheets(4).Visible = True
Sheets(1).Visible = xlVeryHidden
Sheets(2).Visible = xlVeryHidden
Else
Sheets(3).Visible = xlVeryHidden
Sheets(4).Visible = xlVeryHidden
End If
End Sub
What you need to do is to loop thorugh all Sheets in your workbook, and if your Sheet.Index is larger than 2, then make the sheet Visible.
See loop below :
Dim Sht As Worksheet
' loop through all worksheets in this workbook
For Each Sht In ThisWorkbook.Worksheets
If Sht.Index > 2 Then ' check if index > 2
Sht.Visible = xlSheetVisible
Else
Sht.Visible = xlVeryHidden
End If
Next Sht
Entire Code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Sht As Worksheet
If Range("H5").Value = "ADMIN" Then
Sheets(2).Visible = True
Sheets(2).Activate
Else
Sheets(2).Visible = xlVeryHidden
End If
If Range("G8").Value = True And Range("H5").Value = "" Then
For Each Sht In ThisWorkbook.Worksheets
If Sht.Index > 2 Then
Sht.Visible = xlSheetVisible
End If
Next Sht
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Sht As Worksheet
If Range("H5").Value = "ADMIN" Then
Sheets(2).Visible = True
Sheets(2).Activate
Else
Sheets(2).Visible = xlVeryHidden
End If
If Range("G8").Value = True And Range("H5").Value = "" Then
For Each Sht In ThisWorkbook.Worksheets
If Sht.Index > 2 Then
Sht.Visible = xlSheetVisible
Sheets(1).Visible = xlVeryHidden
' Else
' Sht.Visible = xlVeryHidden
End If
Next Sht
'Else
' Sheets(3).Visible = xlVeryHidden
' Sheets(4).Visible = xlVeryHidden
End If
End Sub
edited to reflect Adnan last code
you may try this code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iSht As Long
Sheets(2).Visible = xlVeryHidden '<--| you'll make it visible if the case (see below)
Select Case Range("H5").Value '<--| check for H5 cell only once
Case "ADMIN"
Sheets(2).Visible = True
Sheets(2).Activate
Case ""
If Range("G8").Value Then '<--| check for it only when H5 cell value <> "ADMIN"
For iSht = 3 To Sheets.count '<--| loop through sheets indexes greater than 2, and avoid 'If ... Then' check
Sheets(iSht).Visible = True
Next iSht
Sheets(1).Visible = xlVeryHidden '<--| hide first sheet only once
End If
End Select
End Sub
which does the same things as yours but some logic improvements:
doesn't check twice for Range("H5").Value
doesn't check for Range("G8").Value uselessly after Range("H5").Value is "ADMIN"
doesn't make the If Sht.Index > 2 Then check at every For Each Sht In ThisWorkbook.Worksheets loop
doesn't set Sheets(1).Visible = xlVeryHidden at every For Each Sht In ThisWorkbook.Worksheets loop
I want to remove all sheets in the current workbook exception the list in {A2,A3, ... } and the sheet with name Summary.
I wrote the following code
Dim MyCell As Range, MyRange As Range
Set MyRange = Sheets("Summary").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbook = ActiveWorkbook
For Each xWs In wbook.Worksheets
For Each MyCell In MyRange
If xWs.Name <> MyCell.Value And xWs.Name <> "Summary" Then
xWs.Delete
End If
Next MyCell
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
but I get an run time error which I do not know what it is.
Then, I tried to run line by line: in the first loop over "xWs.Name= Summary" there is no problem first for the second sheet I get an error at
If xWs.Name <> MyCell.Value And xWs.Name <> "Summary" Then
I know that this code is not efficient at all, because if a name matches it is still running till the end of set of names. However, I did not know how I can compare tow sets in VBA in a efficient way.
One can see in the the list of names in A-column.
You need to approach it a little different, you need to loop though the Range on every Sheet, once you have a match you need to raise a flag not to delete this Sheet.
Try the code below:
Sub DeleteSelectedSheets()
Dim MyCell As Range, MyRange As Range
Dim wbook As Workbook, xWs As Worksheet
Dim DeleteSheetFlag As Boolean
Set MyRange = Sheets("Summary").Range("A2")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbook = ActiveWorkbook
For Each xWs In wbook.Worksheets
DeleteSheetFlag = True
For Each MyCell In MyRange
Select Case xWs.Name
Case MyCell.Value, "Summary"
DeleteSheetFlag = False
Exit For
End Select
Next MyCell
If DeleteSheetFlag Then
xWs.Delete
End If
Next xWs
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I ahve an Excel work book containing a large number of sheets. Each sheet has between 1 and 12 Hyperlinks to different documents on a website. These dicuments are updated from time to time. I would like a macro that lists all the Hyperlinks in a new sheet but also lists the sheet name next to each link. I have the following that lists the Hyperlinks and the cell ref
Sub CopyHyperLinks()
Dim rCell As Range
Dim ws As Worksheet
Dim Lhyper As Long
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Hypers").Delete
On Error Goto 0
Application.DisplayAlerts = True
Sheets.Add().Name = "Hypers"
For Each ws In Worksheets
If ws.Name <> "Hypers" Then
For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count
ws.Hyperlinks(Lhyper).Range.Copy
With Sheets("Hypers").Cells(Rows.Count, 1).End(x1Up)
.Offset(1, 0).PasteSpecial
.Offset(1, 1) = ws.Hyperlinks(Lhyper).Range.Address
End
Application.CutCopyMode = False
Next Lhyper
End If
Next ws
End Sub
How can i modify this to show the sheet name instead of the cell ref.
is it also possible to then check that these Hyperlinks are valid destinations?
You can get the name of the worksheet of the hyperlink with this line:
ws.Hyperlinks(Lhyper)..Range.Worksheet.Name
Here's is your reworked code (it contained some other syntactical errors that I corrected):
Sub CopyHyperLinks()
Dim rCell As Range
Dim ws As Worksheet
Dim Lhyper As Long
Dim rngLink As Range
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Hypers").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Sheets.Add().Name = "Hypers"
For Each ws In Worksheets
If ws.Name <> "Hypers" Then
For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count
Set rngLink = ws.Hyperlinks(Lhyper).Range
rngLink.Copy
With Sheets("Hypers").Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).PasteSpecial
.Offset(1, 1) = rngLink.Address
.Offset(1, 2) = rngLink.Worksheet.Name
.Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address)
End With
Application.CutCopyMode = False
Next Lhyper
End If
Next ws
End Sub
If you want to verify the links, include the code from this answer. Include this line in your code:
.Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address)
and also this routine:
Public Function CheckHyperlink(ByVal strUrl As String) As Boolean
Dim oHttp As New MSXML2.XMLHTTP30
On Error GoTo ErrorHandler
oHttp.Open "HEAD", strUrl, False
oHttp.send
If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True
Exit Function
ErrorHandler:
CheckHyperlink = False
End Function
You need to include a reference to the "Microsoft XML" library in your VBA project.