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
Related
I have created an UserForm in Excel. The UserForm has a ListBox and a CheckBox added to it.
I have written VBA code to populate the ListBox with data in the 1st column of the UserForm_Data worksheet. I am attempting to add a Select All CheckBox to the UserForm. When I click on the CheckBox once, the check mark does not appear but the If Me.CheckBox.Value = True section of the Checkbox1_Change event is executed and all the items in the ListBox are selected. The check mark appears only when I click the CheckBox the second time. The Excel VBA code and an image of the UserForm are attached.
Option Explicit
Private Sub ListBox1_Change()
Dim i As Long
If CheckBox1.Value = True Then
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = False Then
Me.CheckBox1.Value = False
End If
Next i
End If
End Sub
Private Sub CheckBox1_Change()
Dim i As Long
If Me.CheckBox1.Value = True Then
With Me.ListBox1
For i = 0 To .ListCount - 1
.Selected(i) = True
Next i
End With
Else
i = 0
End If
End Sub
Private Sub UserForm_Initialize()
Dim rng1 As Range
Dim ws1 As Worksheet
Dim i, lastRow As Long
Dim list1 As Object
Dim string1 As String
Dim array1 As Variant
Set list1 = CreateObject("System.Collections.ArrayList")
Set ws1 = ThisWorkbook.Worksheets("UserForm_data")
lastRow = ws1.UsedRange.Rows.Count
Me.ListBox1.Clear
For i = 2 To lastRow
string1 = CStr(ws1.Cells(i, 1).Value)
If Not list1.Contains(string1) Then
list1.Add string1
End If
Next i
array1 = list1.ToArray
Me.Caption = "UserForm1"
Me.ListBox1.list = array1
Me.ListBox1.MultiSelect = 1
Me.CheckBox1.Value = False
End Sub
There are two steps you can take to address this:
There's a chance that simply adding a DoEvents at the end of the CheckBox1_Change event will force the redraw.
If that doesn't work, add the following line just above the DoEvents and test it again... this encourages a screen update...
Application.WindowState = Application.WindowState
One approach is to use global flags to toggle on and off the control event handlers. Here is what the updated events would look like:
Option Explicit
Private Sub ListBox1_Change()
Dim i As Long
If Not AllowListBoxEvents Then Exit Sub
AllowCheckBoxEvents = False
If CheckBox1.Value = True Then
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = False Then CheckBox1.Value = False
Next i
End If
AllowCheckBoxEvents = True
End Sub
Private Sub CheckBox1_Change()
Dim i As Long
If Not AllowCheckBoxEvents Then Exit Sub
AllowListBoxEvents = False
If CheckBox1.Value = True Then
For i = 0 To ListBox1.ListCount - 1
ListBox1.Selected(i) = True
Next i
End If
AllowListBoxEvents = True
End Sub
Make sure you set the "Allow" variables to True in the Initialize event.
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
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
I've tried just about every option of modeless possible to get this to work I just cannot get it figured out. What I have is a Userform ( Main_Window ) that has a script, and on command button it executes Master_Flex_Filter_Generate()
In that code I have
' Connect and execute the SQL
rs.Open sqlString, conn, adOpenStatic
' Check if we have data.
If Not rs.EOF Then
' Dump column names in first row.
For i = 0 To rs.Fields.count - 1
ActiveSheet.Cells(1, i + 1) = rs.Fields(i).Name
Next i
Do
' Transfer results beginning at A2 from rs
ActiveSheet.Range("A2").CopyFromRecordset rs
Loop Until rs.EOF
' Close the recordset
rs.Close
' Define Record_Count as the amount of records returned. Subtract 1 for the header
Record_Count = Cells(Rows.count, "A").END(xlUp).Row - 1
' Return box on success
Answer = MsgBox((Record_Count & " Records returned") & vbCrLf & vbCrLf & "Reminder" & vbCrLf & "- This data set is already defined as a range. This allows you to create a new pivot table and use the named range: " & ActiveSheet.Name & vbCrLf & vbCrLf & "Do you want to create a Pivot Table from this data?", vbYesNo + vbQuestion, "Query generated succesfully")
' close user form
Unload mod_loading
Unload Main_Window
' Clean up
If CBool(conn.State And adStateOpen) Then conn.Close
Set conn = Nothing
Set rs = Nothing
'Now lets define this data as a range for pivot table use
Dim ActSheet As Worksheet
Dim ActSheetName As String
'This sets up an object reference to the activesheet
Set ActSheet = Sheets(ActiveSheet.Name)
'This places a string value in the variable
ActSheetName = ActiveSheet.Name
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set sheetname = ActiveWorkbook.ActiveSheet
ws.Range("A1").Select
ActiveWorkbook.Names.Add Name:="data", RefersToR1C1:= _
"=OFFSET(R1C1,0,0,COUNTA(C1),COUNTA(R1))"
wb.Names("data").Name = ActSheetName
'Filter, freeze pain, and align columns
Rows("1:1").Select
Selection.AutoFilter
Selection.Font.Bold = True
Columns("A:IV").AutoFit
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
'Take answer form msgbox and do something with it
If Answer = vbYes Then
'If yes, create pivot table
Sheets("Pivot").Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"data", Version:=xlPivotTableVersion14).CreatePivotTable TableDestination _
:="Pivot!R1C1", TableName:="PivotTable1", DefaultVersion:= _
xlPivotTableVersion14
Sheets("Pivot").Select
Cells(1, 1).Select
End If
Else
mod_loading.Hide
MsgBox "Error: No records returned for your criteria.", vbCritical
End If
This form works perfectly as is here. I have another Userform called mod_loading that looks like this
Sub UserForm_Activate()
DoEvents
Do
mod_loading.loading_beag.Visible = False
mod_loading.loading_splines.Visible = True
Sleep 2000
DoEvents
mod_loading.loading_splines.Visible = False
mod_loading.loading_sheep.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_sheep.Visible = False
mod_loading.loading_meteor.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_meteor.Visible = False
mod_loading.loading_ozone.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_ozone.Visible = False
mod_loading.loading_terrain.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_terrain.Visible = False
mod_loading.loading_gravity.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_gravity.Visible = False
mod_loading.loading_advisor.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_advisor.Visible = False
mod_loading.loading_pool.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_pool.Visible = False
mod_loading.loading_leaks.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_leaks.Visible = False
mod_loading.loading_beag.Visible = True
Sleep 5000
DoEvents
Loop
End Sub
Both of these forms work as is, where I'm having the problem is placing mod_loading.Show anywhere in Master_Flex_Filter_Generate(). No matter what I set for modeless the mod_loading will run until it completely finishes. It won't let the code in Main_Window to continue running, so it halts that code. Any ideas? I was thinking it's perhaps because I'm not playing mod_loading.Show inside a loop, but since my connection string doesn't have a loop I can't figure out how to do it.
I placed the code inside If Not rs.EOF THEN but 99% of the code loads on rs.Open which is outside of the loop.
EDIT
Okay so I have changed my script all around and have placed all SQL logic inside the userform for the loading dialog. So I have Main_Window which is the form, then it calls the sub from the loading userform which pops up just fine. So I now have the loading dialog pop up and goes away just fine as intended. My only problem is now, it doesn't loop through my sleep commands. It just remains on the very first one.
Here is my code for the loading userform
Sub UserForm_Activate()
DoEvents
Call Master_Flex_Filter_Generate
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_beag.Visible = False
loading_masterflexfilter.loading_splines.Visible = True
Sleep 500
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_splines.Visible = False
loading_masterflexfilter.loading_sheep.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_sheep.Visible = False
loading_masterflexfilter.loading_meteor.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_meteor.Visible = False
loading_masterflexfilter.loading_ozone.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_ozone.Visible = False
loading_masterflexfilter.loading_terrain.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_terrain.Visible = False
loading_masterflexfilter.loading_gravity.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_gravity.Visible = False
loading_masterflexfilter.loading_advisor.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_advisor.Visible = False
loading_masterflexfilter.loading_pool.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_pool.Visible = False
loading_masterflexfilter.loading_leaks.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_leaks.Visible = False
loading_masterflexfilter.loading_beag.Visible = True
Sleep 1000
DoEvents
End Sub
I have the following code that loads a worksheet in full screen for 1 minute, and then moves onto the next worksheet in the workbook, using the exactly the same methodology.
This is to show stats on a big screen, looping through several stats pages.
This works perfectly on Excel 2007 and 2010.
Yet when the same code is executed on Excel 2013, Excel simply maxes out 1 core of my CPU and stays at not responding. I cannot even Escape to break the code execution. Stepping through the code line by line works fine on all versions.
'Loads up Daily Dispatch Figures worksheet
Application.ScreenUpdating = False
Sheets("Daily Dispatch Figures").Select
Range("A1").Select
Range("A1:C36").Select
ActiveWindow.Zoom = True
Range("A1").Select
ActiveWindow.DisplayHeadings = False
Application.DisplayFormulaBar = False
Application.DisplayFullScreen = True
Application.ScreenUpdating = True
' Stays on this screen for 1 min
TimVal = Now + TimeValue("0:01:00")
Do Until Now >= TimVal
Loop
Ooo, don't do this:
' Stays on this screen for 1 min
TimVal = Now + TimeValue("0:01:00")
Do Until Now >= TimVal
Loop
Try this:
Application.OnTime Now + TimeValue("0:01:00"), "ProcedureToRun"
You don't want to catch your application in an infinite loop with no sleeps.
Any time you sit in an infinite loop without sleeping, it will use 100% of your Processor time doing nothing. Application.OnTime "schedules" an event and returns control to the Excel UI Thread instead of infinitely looping.
You can read more here: https://msdn.microsoft.com/en-us/library/office/ff196165.aspx
I'm not sure what you're doing after your loop, but you need to make sure you have the code in a separate subroutine and call it.
Here is a Subroutine to go to the next sheet.
Sub MoveNext()
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
On Error Goto 0
End Sub
You can add the Application.OnTime to the end of it and have it call itself:
Sub MoveNext()
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
On Error Goto 0
Application.OnTime Now + TimeValue("00:01:00"), MoveNext
End Sub
This way it will loop and go from sheet to sheet forever (or until you stop it in whatever method you choose to use).
Finally, you can cancel this by storing the scheduled time and using Scheduled:=False.
Your final code could look something like this:
Public scheduledTime as Date
Sub StartDisplaying()
'Your start code:
'---------------------------------------------
Application.ScreenUpdating = False
Sheets("Daily Dispatch Figures").Select
Range("A1").Select
Range("A1:C36").Select
ActiveWindow.Zoom = True
Range("A1").Select
ActiveWindow.DisplayHeadings = False
Application.DisplayFormulaBar = False
Application.DisplayFullScreen = True
Application.ScreenUpdating = True
'---------------------------------------------
scheduledTime = Now + TimeValue("00:01:00")
Application.OnTime scheduledTime, MoveNext
End Sub
Sub StopDisplaying()
'Your stop code:
'---------------------------------------------
Application.ScreenUpdating = False
Sheets("Daily Dispatch Figures").Select
ActiveWindow.Zoom = False
ActiveWindow.DisplayHeadings = True
Application.DisplayFormulaBar = True
Application.DisplayFullScreen = False
Application.ScreenUpdating = True
'---------------------------------------------
Application.OnTime EarliestTime:=scheduledTime, Procedure:="MoveNext", Schedule:=False
End Sub
Sub MoveNext()
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
On Error Goto 0
scheduledTime = Now + TimeValue("00:01:00")
Application.OnTime scheduledTime, MoveNext
End Sub