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
Related
I've been using the following VBA macro code below to hide all but the active worksheet:
Sub HideWorksheets()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> ThisWorkbook.ActiveSheet.Name Then
ws.Visible = xlSheetHidden
End If
Next ws
End Sub
Are there any options to extend it so that it will hide all but the selected worksheets?
You need to access the Windows(#).SelectedSheets. One way is to hide all except ActiveSheet, then unhide those Selected.
Option Explicit
Sub HideWorksheets()
Dim ws As Worksheet
Application.ScreenUpdating = False
' Hide all except activeone
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> ThisWorkbook.ActiveSheet.Name Then ws.Visible = xlSheetHidden
Next
' Unhide selected worksheets
For Each ws In ThisWorkbook.Windows(1).SelectedSheets
ws.Visible = xlSheetVisible
Next ws
Application.ScreenUpdating = True
End Sub
I am trying to write a macro that will ask user to provide workbook, macro opens workbook. Than user selects the range for copy and specifies the worksheet to which paste data in Userform. Macro copy selected Range to the specified worksheet.
But I face some problems with it.
Here is code:
Public Sub copy_WB()
Application.DisplayAlerts = False
Dim wbk As Workbook, answer As String,lrow as long, lcol as long
Dim UserRange As Range
Prompt = "Select a cell for the output."
Title = "Select a cell"
answer = MsgBox("Would you like to clear all data?", vbYesNo, "Confirmation")
If answer = vbYes Then
Call clear_all
End If
Set wbk = Get_workbook
If wbk Is Nothing Then
Exit Sub
End If
' Display the Input Box
On Error Resume Next
Set UserRange = Application.InputBox( _
Prompt:=Prompt, _
Title:=Title, _
Type:=8) 'Range selection
' Was the Input Box canceled?
If UserRange Is Nothing Then
MsgBox "Canceled."
Exit Sub
Else
UserRange.Parent.Parent.Activate
UserRange.Parent.Activate
lrow = UserRange(UserRange.Count).Row
lcol = UserRange(UserRange.Count).Columns
If lrow > 1000000 Or lcol > 15000 Then
ActiveSheet.UsedRange.Copy
Else
UserRange.Copy
End If
sh_sel.Show
Do While IsUserFormLoaded("sh_sel")
DoEvents
Loop
ActiveSheet.Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
ThisWorkbook.Worksheets(3).Range("A1") = lrow
ThisWorkbook.Worksheets(3).Range("A2") = lcol
wbk.Close False
Application.DisplayAlerts = True
End Sub
Private Sub clear_all()
Dim wb As Workbook, shs As Worksheet, lrow As Single, lcol As Single
Set wb = ThisWorkbook
For Each shs In wb.Worksheets
With shs.UsedRange
lrow = .Rows(.Rows.Count).Row
lcol = .Columns(.Columns.Count).Column
End With
If Not (lrow = 0 Or lrow = 1) Then
With shs
.Range(.Cells(2, 1), .Cells(lrow, lcol)).clear
End With
End If
Next shs
End Sub
Function Get_workbook() As Workbook
Dim wbk As Workbook, pathb As String
pathb = ThisWorkbook.path
ChDir pathb
wbk_name = Application.GetOpenFilename(Title:="Please choose File:", FileFilter:="Excel Files *.xls*(*.xls*),")
On Error Resume Next
If Len(Dir(wbk_name)) = 0 Then
MsgBox "The file was not chosen - macro off."
Exit Function
Else
Set wbk = Workbooks.Open(wbk_name)
End If
Set Get_workbook = wbk
End Function
Function IsUserFormLoaded(ByVal UFName As String) As Boolean
Dim UForm As Object
IsUserFormLoaded = False
For Each UForm In VBA.UserForms
If UForm.Name = UFName Then
IsUserFormLoaded = True
Exit For
End If
Next
End Function 'IsUserFormLoaded
The first problem that I am facing is when user press
The button which locates in the upper left corner of the sheet to select the entire sheet range, it will not be copied. I was trying to correct it somehow by adding the condition of last row of selected range is bigger then...(see code please).
But it does not actually works. sometimes it copy range, sometimes no.
The second problem: inputbox is disappears when macro run. Have no idea why it happans.
Userform code:
Private Sub UserForm_Initialize()
Dim sh As Worksheet
For Each sh In ThisWorkbook.Sheets
ListBox1.AddItem sh.Name
Next sh
Me.StartUpPosition = 0
Me.Left = Application.Left + (0.5 * Application.Width) - (0.5 * Me.Width)
Me.Top = Application.Top + (0.5 * Application.Height) - (0.5 * Me.Height)
HideTitleBar.HideTitleBar Me
End Sub
Private Sub ListBox1_Click()
ThisWorkbook.Sheets(ListBox1.Value).Activate
Unload Me
End Sub
User forms contains list of sheets in current workbook, after user selection of the sheet data would be pasted.
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
I've made a macro that scans for a open file beginning with ME2N. The macro should then copy the range A2:Px (last row) in the sheet and insert it in the sheet of a differenz workbook (range B:Q). After inserting the content of the sheet ME2N[...] the macro should insert a formula in column A.
Problem: I can see when I run the macro that it inserts a formula but nothing more. It seems like the macro doesn't copy the content of the sheet ME2N[...]. Maybe the macro is too fast for excel?
Sub CopyData()
Dim Wb1 As Workbook, wb2 As Workbook, wB As Workbook
Dim rngToCopy As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If MsgBox("Alte Daten löschen und neue übertragen?", vbYesNo) = vbNo Then Exit Sub
Worksheets("Input").Range("A5:Q2500").clearcontents
For Each wB In Application.Workbooks
If Left(wB.Name, 4) = "ME2N" Then
Set Wb1 = wB
Exit For
End If
Next
If Not Wb1 Is Nothing Then
Set wb2 = ThisWorkbook
With Wb1.Sheets(1)
Set rngToCopy = .Range("A2:P2", .Cells(.Rows.Count, "A").End(xlUp))
End With
wb2.Sheets(2).Range("B5:Q5").Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Range("A5").Formula = "=IF(INDIRECT(""B""&ROW())="""","""",CONCATENATE(INDIRECT(""B""&ROW()),""/"",INDIRECT(""C""&ROW()),""/"",INDIRECT(""F""&ROW())))"
Range("A5").Copy
Range("A5:A2500").PasteSpecial (xlPasteAll)
If Application.CalculationState = xlDone Then
Range("A5:Q2500").Copy
Range("A5:Q2500").PasteSpecial xlPasteValues
End If
End Sub
I couldn't recreate your issue, it worked fine for me. I don't know whether this method of using the formula may make a difference though:
Sub CopyData()
Dim Wb1 As Workbook, wb2 As Workbook, wB As Workbook
Dim rngToCopy As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If MsgBox("Alte Daten löschen und neue übertragen?", vbYesNo) = vbNo Then Exit Sub
Worksheets("Input").Range("A5:Q2500").ClearContents
For Each wB In Application.Workbooks
If Left(wB.Name, 4) = "ME2N" Then
Set Wb1 = wB
Exit For
End If
Next
If Not Wb1 Is Nothing Then
Set wb2 = ThisWorkbook
With Wb1.Sheets(1)
Set rngToCopy = .Range("A2:P2", .Cells(.Rows.Count, "A").End(xlUp))
End With
wb2.Sheets(2).Range("B5:Q5").Resize(rngToCopy.Rows.Count).Value = rngToCopy.Value
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Range("A5").Formula = "=IF(INDIRECT(""B""&ROW())="""","""",CONCATENATE(INDIRECT(""B""&ROW()),""/"",INDIRECT(""C""&ROW()),""/"",INDIRECT(""F""&ROW())))"
Range("A5").AutoFill Destination:=ActiveCell.Range("A1:A2500")
If Application.CalculationState = xlDone Then
Range("A5:Q2500").Value = Range("A5:Q2500").Value
End If
End Sub
I have adapted the following code from Contextures website which adds combo box functionality into cells containing data validation. Though comboboxes display well where they should, I am still facing two issues.
First, I would need that after chosing value in "D4" cell, which combines data validation and combo box, the same value was displayed on other sheets in "D4" cell in the workbook. Unfortunately, after comboboxes code was added, the Workbook_SheetChange code stopped working. I assume it is because it cannot find Target in data validation/combobox cell now.
The second issue is that the Worksheet_SelectionChange code below causes screen flickering even though Application.ScreenUpdating is applied. Is there any way to get rid of it?
I would be greatful for any solutions.
EDIT:
At last I managed to find solution to first issue myself. I ommited Workbook_SheetChange event entirely and replaced with ComboShtHeader_KeyDown and ComboShtHeader_LostFocus events, both placed in the workbook sheets. These macros ensure that value of a cell changes on all sheets either on pressing Tab, Enter or click outside "D4" cell. I am placing both codes below for the case that someone faces similar issue.
The other issue with screen flickering in Worksheet_SelectionChange code persists though. Solutions are still welcome.:-)
Private Sub ComboShtHeader_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'change "D4" cell value on all sheets on pressing TAB or ENTER
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
Select Case KeyCode
Case 9 'Tab
ActiveCell.Offset(0, 1).Activate
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range(ActiveCell.Offset(0, -3).Address).Value = ActiveCell.Offset(0, -3).Value
End If
Next ws
Case 13 'Enter
ActiveCell.Offset(1, 0).Activate
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range(ActiveCell.Offset(-1, 0).Address).Value = ActiveCell.Offset(-1, 0).Value
End If
Next ws
Case Else
'do nothing
End Select
End Sub
Private Sub ComboShtHeader_LostFocus()
'change "D4" cell value on all sheets on click outside "D4" cell
Dim ws1 As Worksheet, ws As Worksheet
Set ws1 = ActiveSheet
For Each ws In Worksheets
If ws.Name <> ws1.Name Then
ws.Range("D4").Value = ws1.Range("D4").Value
End If
Next ws
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet, ws2 As Worksheet
Dim ComHead As OLEObject, ComBody As OLEObject
Dim Str As String
Application.ScreenUpdating = False
On Error GoTo ErrHandler
Set ws = ActiveSheet
Set ws2 = Worksheets("lists")
Set ComHead = ws.OLEObjects("ComboShtHeader")
Set ComBody = ws.OLEObjects("ComboShtBody")
On Error Resume Next
If ComHead.Visible = True Then
With ComHead
.Top = 34.5
.Left = 120
.Width = 20
.Height = 15
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
End If
On Error Resume Next
If ComBody.Visible = True Then
With ComBody
.Top = 34.5
.Left = 146.75
.Width = 20
.Height = 15
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
End If
On Error GoTo ErrHandler
'If the cell contains a data validation list
If Target.Validation.Type = 3 Then
If Target.Address = ws.Range("D4:F4").Address Then
If Target.Count > 3 Then GoTo ExitHandler
Application.EnableEvents = False
'Get the data validation formula
Str = Target.Validation.Formula1
Str = Right(Str, Len(Str) - 1)
With ComHead
'Show the combobox with the validation list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height
.ListFillRange = ws2.Range(Str).Address(external:=True)
.LinkedCell = Target.Address
End With
ComHead.Activate
'Open the dropdown list automatically
Me.ComboShtHeader.DropDown
Else
If Target.Count > 1 Then GoTo ExitHandler
Application.EnableEvents = False
'Get the data validation formula
Str = Target.Validation.Formula1
Str = Right(Str, Len(Str) - 1)
With ComBody
'Show the combobox with the validation list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height
.ListFillRange = ws2.Range(Str).Address(external:=True)
.LinkedCell = Target.Address
End With
ComBody.Activate
'Open the dropdown list automatically
Me.ComboShtBody.DropDown
End If
End If
ExitHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrHandler:
Resume ExitHandler
End Sub
The second code, placed in ThisWorkbook module and currently not working:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wb1 As Workbook
Dim ws1 As Worksheet, ws As Worksheet
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set wb1 = ThisWorkbook
Set ws1 = Sh
On Error GoTo LetsContinue
'This should change "D4" value on all sheets, but does not work after combobox feature was added to the sheets.
If Not Intersect(Target, ws1.Range("D4")) Is Nothing Then
MsgBox Target.Address 'returns nothing
For Each ws In wb1.Worksheets
If Target.Value <> ws.Range(Target.Address).Value Then
ws.Range(Target.Address).Value = Target.Value
End If
Next ws
Else
GoTo LetsContinue
End If
LetsContinue:
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Actually, the second issue that regarded screen flickering solved itself when I moved from Excel 2007 to 2013 version. It seems like some kind of bug in older version.