Userform stops other sheets from scrolling - vba

I have a few userforms. One is a popup that shows instructions and another is for entering quantities. Problem is when I click one and close it (each closes with Unload Me) then when I switch sheets with a sht.Activate macro button that sheet won't scroll. Looks like the sheet is frozen. I can fix the problem by loading the userform and closing it again on the current sheet to "Unfreeze" the sheet.
Any idea why this is happening?
UserForm
Private Sub UserForm_Click()
Unload Me
End Sub
Below is how I call it from a button.
Sub Instructions()
With UserFormInstructions
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
.Show
End With
End Sub
Sheet Button
Sub goto630()
Application.ScreenUpdating = False
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Worksheets("Foundation Plates")
Dim sht3 As Worksheet
Set sht3 = ThisWorkbook.Worksheets("630 BOM")
sht3.Activate
sht3.Unprotect
sht2.Visible = True
sht3.Visible = True
On Error GoTo 0
ActiveWindow.Zoom = 90
ActiveWindow.DisplayHeadings = True
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
Application.DisplayFormulaBar = True
sht3.DisplayPageBreaks = False
sht2.Protect
sht3.Protect _
DrawingObjects:=False, _
Contents:=True, _
Scenarios:=False, _
UserInterFaceOnly:=False, _
AllowFormattingCells:=True
Call NoSelect
Set sht3 = Nothing
Application.ScreenUpdating = True
End Sub
Sub NoSelect()
Application.ScreenUpdating = False
Range("D1").Select
ActiveWindow.SmallScroll ToLeft:=4
Application.ScreenUpdating = True
End Sub
Thanks

Related

After Running Macro Excel will not close, sheet will not scroll, and arrow key causes selection to jump wildly

I have created a report template that allows users to select various filters and then creates specific reports based on those filters. Below is the code for the filter selection button:
Sub Filter_Select()
rptSelect.Show
End Sub
After this, users are presented with UserForms to select different filters. Each UserForm calls the next user form until they reach the last UserForm whose code is such:
Private Sub UserForm_Activate()
With milSelect
.Top = Application.Top + 250
.Left = Application.Left + 250
End With
End Sub
--------------------------------------------------
Private Sub UserForm_Initialize()
milDV.RowSource = Range("Q1:Q8").Address
End Sub
--------------------------------------------------
Private Sub CancelmilSelect_Click()
Unload Me
End Sub
--------------------------------------------------
Private Sub OKmilSelect_Click()
Sheets("Report Selection").Unprotect
Range("B6").ClearContents
Range("B6") = milDV.Text
Unload Me
Call Create_Report
End Sub
Once they select the final filter, the Create_Report macro is run to determine which reports to create and what formulas to use based on the filters selected. The code is as such:
Option Explicit
Sub Create_Report()
'
' Macro to update fields in different reporting sections after user selects report type
'
'
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'
' Display Tabs
'
Dim z As Integer
For z = 2 To Worksheets.Count
Sheets(z).Visible = xlSheetHidden
Next z
If Range("B1").Value = "National" And Range("B6") = "Military" Then
Sheets("Program Summary").Visible = xlSheetVisible
Else
If Range("B1") = "National" Then
Sheets("Program Summary").Visible = xlSheetVisible
Sheets("Family & Household Demographics").Visible = xlSheetVisible
Sheets("Registered Member Dues").Visible = xlSheetVisible
Else
Sheets("Program Summary").Visible = xlSheetVisible
Sheets("Summary").Visible = xlSheetVisible
Sheets("Financial Summary").Visible = xlSheetVisible
End If
End If
'
' Financial Summary
'
If Sheets("Financial Summary").Visible = True Then
Sheets("Financial Summary").Select
Sheets("Financial Summary").Unprotect
'
' Name Ranges
'
Dim Operating_Expenses, Income_Private1, Income_Private2, Income_Private3, Income_Gov, Income_Other1, Income_Other2 As Range
Set Operating_Expenses = Range("C5:C7")
Set Income_Private1 = Range("C13")
Set Income_Private2 = Range("C14:C16")
Set Income_Private3 = Range("C17")
Set Income_Gov = Range("C19:C22")
Set Income_Other1 = Range("C25:C26")
Set Income_Other2 = Range("C27:C30")
'
' State Non-Military Financial Summary
'
If Worksheets("Report Selection").Range("B1").Value = "State" Then
If Worksheets("Report Selection").Range("B6").Value = "Non-Military" Then
Range("B1").Value = Worksheets("Report Selection").Range("B4").Value
Range("C1").Value = "Non-Military"
Operating_Expenses.Formula = "=SUMIFS(INDEX('Financial Data'!$BE:$BG, 0, ROW(1:1)),'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
Income_Private1.Formula = "=SUMIFS(INDEX('Financial Data'!$AO:$AO, 0, ROW(1:1)),'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
Income_Private2.Formula = "=SUMIFS(INDEX('Financial Data'!$AL:$AN, 0, ROW(1:1)),'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
Income_Private3.Formula = "=SUMIFS(INDEX('Financial Data'!$AQ:$AQ, 0, ROW(1:1)),'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
Income_Gov.Formula = "=SUMIFS(INDEX('Financial Data'!$BA:$BD, 0, ROW(1:1)),'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
Range("C24").Formula = "=SUMIFS('Financial Data'!$AP:$AP,'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
Income_Other1.Formula = "=SUMIFS(INDEX('Financial Data'!$AV:$AW, 0, ROW(1:1)),'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
Income_Other2.Formula = "=SUMIFS(INDEX('Financial Data'!$AR:$AU, 0, ROW(1:1)),'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
Range("C31").Formula = "=SUMIFS('Financial Data'!$AZ:$AZ,'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
Range("C32").Formula = "=SUMIFS('Financial Data'!$AY:$AY,'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
Range("C33").Formula = "=SUMIFS('Financial Data'!$AK:$AK,'Financial Data'!$E:$E,$B$1,'Financial Data'!$H:$H,""0"")"
End If
End If
End If
'
' Select First Sheet of Report
'
Dim i As Integer
Dim ws As Worksheet
For i = 1 To Worksheets.Count
If Sheets(i).Visible = True Then
Sheets(i).Protect
End If
Next i
For i = 2 To Worksheets.Count
If Sheets(i).Visible = True Then
Sheets(i).Select
Exit For
End If
Next i
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
All of the code runs properly and the reports are created, but I'm having a bug where when I try to scroll on the sheet that is displayed after the code runs, the scroll bar moves but the cells seem stuck in place. If I try to select a cell and move with the arrow key, the selection jumps around. Both of these things are solved by going to another sheet and then coming back.
Additionally, after this code runs, I cannot close Excel with any method other than through Task Manager. Since none of this happens when I first open the workbook, I am left to assume that my above code is somehow causing this.
Sorry it took so long to get back to this. I've been swamped the past week. Anyways, I've finally solved the problem thanks to some direction from #Comintern. Basically, I took all of the grunt work out of each of my forms and put it in the Module that the filter button calls.
Not only is this a more streamlined and efficient way to work with the code, it also provides a centralized location to assess any errors that may crop-up essentially eliminating a few possible points of failure. Below is both the code for the filter button and the code for one of the filter forms.
New form code:
Private Sub UserForm_Activate()
With milSelect
.Top = Application.Top + 250
.Left = Application.Left + 250
End With
End Sub
---------------------------------------------------
Private Sub UserForm_Initialize()
milDV.RowSource = Range("Q1:Q8").Address
End Sub
Private Sub CancelmilSelect_Click()
Unload Me
End Sub
---------------------------------------------------
Private Sub OKmilSelect_Click()
Sheets("Report Selection").Unprotect
Range("B6").ClearContents
Range("B6") = milDV.Text
Me.Hide
End Sub
Filter button code:
Sub Filter_Select()
Dim ReportType As String
Dim Region As String
Dim ServiceUnit As String
Dim State As String
Dim Military As String
With New rptSelect
.Show vbModal
If Not Cancel = True Then
If Range("B1").Value = "National" Then
With New milSelect
.Show vbModal
If Not Cancel = True Then
Unload rptSelect
Unload milSelect
Call Create_Report
End If
End With
Else
If Range("B1").Value = "Service Unit" Then
With New SUSelect
.Show vbModal
If Not Cancel = True Then
With New milSelect
.Show vbModal
If Not Cancel = True Then
Unload rptSelect
Unload milSelect
Unload SUSelect
Call Create_Report
End If
End With
End If
End With
Else
If Range("B1").Value = "Regional" Then
With New rgnSelect
.Show vbModal
If Not Cancel = True Then
With New milSelect
.Show vbModal
If Not Cancel = True Then
Unload rptSelect
Unload milSelect
Unload rgnSelect
Call Create_Report
End If
End With
End If
End With
Else
If Range("B1").Value = "State" Then
With New stateSelect
.Show vbModal
If Not Cancel = True Then
With New milSelect
.Show vbModal
If Not Cancel = True Then
Unload rptSelect
Unload milSelect
Unload stateSelect
Call Create_Report
End If
End With
End If
End With
End If
End If
End If
End If
End If
End With
End Sub
I'm sure there is probably a cleaner way to write this other than how it appears here and welcome any suggestions anyone may have for making it look better, but for now at least, it is working like a charm. Thanks for everyone's input and patience.

Excel VBA: update cell based on previous cells change

I'm working on an Excel worksheet and using VBA to complete and update information on the cells.
There are seven columns in the Excel table. Three of them are drop-down lists with Data Validation, which I used the following VBA code to fill them.
Private Sub TempCombo_KeyDown(ByVal _KeyCode As MSForms.ReturnInteger, _ ByVal Shift As Integer)
'Ocultar caixa de combinação e mover a próxima célula com Enter e Tab
Select Case KeyCode
Case 9
ActiveCell.Offset(0, 1).Activate
Case 13
ActiveCell.Offset(1, 0).Activate
Case Else
'Nada
End Select
End Sub
These columns also work with autocomplete, using the code below:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Dim wsList As Worksheet
Set ws = ActiveSheet
Set wsList = Sheets(Me.Name)
Application.EnableEvents = False
Application.ScreenUpdating = False
If Application.CutCopyMode Then
'Permite copiar e colar na planilha
GoTo errHandler
End If
Set cboTemp = ws.OLEObjects("TempCombo")
On Error Resume Next
With cboTemp
.Top = 10
.Left = 10
.Width = 0
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
On Error GoTo errHandler
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
With cboTemp
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height + 5
.ListFillRange = str
.LinkedCell = Target.Address
End With
cboTemp.Activate
'Abrir a lista suspensa automaticamente
Me.TempCombo.DropDown
End If
errHandler:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End Sub
Anytime I update any cell on a row, I want that the content of the seventh column of this row is updated with the current date.
I tried using the following code, but it only works with common cells, the ones that I manually type its content. I want the seventh column to be updated when I change the drop-down list selection also.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 1 Then Exit Sub
Application.EnableEvents = False
Cells(Target.Row, "U").Value = Date
End Sub
Is there any way to update the content of the column as I said before? Even when I change the option selected in the drop-down list?
Your code is fine except that you need to turn events back on. You have stopped events from firing with this line: Application.EnableEvents = False but you never turn the event firings back on again. So your code will work the first time you change a cell, the Worksheet_Change event will fire as expected. However, within this sub you have set EnableEvents to false and then never set it back to true. So you have stopped all future events, including this one, from firing again in the future. Here is the solution:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 1 Then Exit Sub
Application.EnableEvents = False
Cells(Target.Row, "U").Value = Date
Application.EnableEvents = True
End Sub

How to lock excel aspect/visual options

I am trying to lock the aspect/visual options of an excel file, so when other people open it, it remains as I set and cannot change it.
When I set the aspect options and other people open it in their PCs, all settings are gone.
I would like to set the aspect as the following:
Do not show formula bar
Do not show headings
Minimize the Ribbon
Additionally I would like to lock specific settings for each sheet:
Zoom:
100% for sheet 1 and 4
90% for sheet 2 and 3
Freeze panes:
Unfreeze for sheet 1 and 4
Freeze the first 3 columns for sheet 2 and 3
Is there anyway of doing this?
Thanks!
I used this in the 'thisworkbook' excel object. The send keys worked but i would be careful as these are prone to errors.
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If ActiveSheet.Name = "Sheet1" Or ActiveSheet.Name = "Sheet4" Then
ActiveWindow.FreezePanes = False
ActiveWindow.Zoom = 90
ElseIf ActiveSheet.Name = "Sheet2" Or ActiveSheet.Name = "Sheet3" Then
Columns("d:d").Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 90
End If
Application.DisplayFormulaBar = False
ActiveWindow.DisplayHeadings = False
If Application.CommandBars("Ribbon").Height >= 150 Then
SendKeys "^{F1}"
End If
End Sub
Hopefully this will work, if not let me know!
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If ActiveSheet.Name = "Sheet1" Or ActiveSheet.Name = "Sheet4" Then
ActiveWindow.FreezePanes = False
ActiveWindow.Zoom = 90
ElseIf ActiveSheet.Name = "Sheet2" Or ActiveSheet.Name = "Sheet3" Then
Columns("d:d").Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 90
End If
Application.DisplayFormulaBar = False
ActiveWindow.DisplayHeadings = False
Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",False)"
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
End Sub

Macro button to switch to previous sheet

So I've been playing around with macros and buttons and I am trying to make a button, that on clicking it, it will go to the previous sheet (they are names Day 1, 2, 3, etc...) so I figure this shouldn't be too difficult!
Here is the code that I have got so far:
Sub Previous_Day()
Worksheets("Day " & (sheetNum - 1)).Visible = xlSheetVisible
Worksheets("Day " & (sheetNum - 1)).Activate
Worksheets("Day " & sheetNum).Visible = xlSheetHidden
sheetNum = sheetNum - 1
End Sub
I get an error when I click the button with this which says "subscript out of range", I'm not entirely sure why this is happening, I globally define sheetNum in the 'This Workbook' module, and I shall show that code below:
Public sheetNum As Integer
Private Sub Workbook_Open()
Dim thisSheet As Worksheet
Dim sh As Worksheet
Dim start As Worksheet
Dim shName As String
Dim lastSheet As String
'name of the sheet template
shName = "Food Diary Template.xltm"
lastSheet = "Food Diary Last Entry.xltm"
Set start = Worksheets(1)
With start
If .Range("A1") = "" Then
.Range("A1") = Date
ActiveSheet.Shapes("Button 5").Select
Selection.Delete
.Range("B4").Select
End If
End With
Worksheets(Sheets.Count).Activate
'#### I like to use variables for worksheets:
Set thisSheet = ThisWorkbook.ActiveSheet
'Insert sheet template
With thisSheet
If .Range("A1") < Date Then
ActiveSheet.Buttons.Add(436.5, 104.25, 58.5, 18.75).Select
Selection.OnAction = "nextDay_Click"
ActiveSheet.Shapes("Button 1").Select
Selection.Characters.Text = "Button 1"
With Selection.Characters(start:=1, Length:=8).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
ActiveSheet.Shapes("Button 1").Select
Selection.Characters.Text = "Next Day"
With Selection.Characters(start:=1, Length:=8).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
.Range("B4").Select
Set sh = Sheets.Add(Type:="C:\Users\edawes\AppData\Roaming\Microsoft\Templates\" & lastSheet, _
after:=Sheets(Sheets.Count))
'#### Put today's date in the new sheet:
sh.Range("A1") = Date
sh.Name = "Day " & Worksheets.Count
'Worksheets(sh).Active
sh.Range("B4").Select
'#### Hide the old sheet
.Visible = xlSheetHidden
End If
End With
sheetNum = Sheets.Count
End Sub
This bit works fine as I want it to, but it's the sheetNum that I'm not sure about, have I done it right? I want it to be the total number of sheets when the file is opened and then when the button is pressed, (there is also a next day button, but that will be pretty simple when I get this one working), it will update the sheetNum variable so that it can keep track and the previous button can keep being pressed...
Any ideas?
You could just parse the Name of he active sheet, subtract one from the day number and activate the previous sheet.
Sub ButtonCode()
dy = CLng(Split(ActiveSheet.Name, " ")(1))
dy = dy - 1
If dy = 0 Then Exit Sub
Sheets("Day " & dy).Activate
End Sub
So if the name of the active sheet is Day 4, then sheet Day 3 would be activated.

Make button appear after 10 seconds

I created one button and after my workbook loads, I want my button to appear after 10 seconds (not right away).
Dim ButtonOneClick As Boolean
Sub Button3_Click()
Sub disenable()
Dim b1 As Button
Set b1 = Sheets("Sheet2").Button3_Click()
Sheets("Sheet2").Button3_Click.Enabled = False
DoEvents
Application.ScreenUpdating = True
For i = 1 To 10
Application.Wait (Now + TimeValue("0:00:1"))
Next i
'Sheets(1).button1.Enabled = False
End Sub
Try this on activating the sheet or adjust to your needs
Private Sub Worksheet_Activate()
Me.Buttons("Button 1").Visible = False
Application.ScreenUpdating = True
Application.Wait (Now + #12:00:10 AM#)
Me.Buttons("Button 1").Visible = True
End Sub