When I activate a sheet I want excel to do the following process:
Is cell "A1 and cell "Z1" in the range of my screen?
Yes:
Do nothing
No:
Range("A1:Z1").Select
ActiveWindow.Zoom = True
I want this because my file has to open on different screens/screen resolutions and everything has to be visible for everyone.
I hope somebody can help me.
Couldn't you just check if the range already fits and if it doesn't call the zoom method?
Option Explicit
Public Sub RunMe()
FitColumns "A:Z"
End Sub
Private Sub FitColumns(addr As String)
Dim oldSel As Range
Dim colRange As Range
Set oldSel = Selection
Set colRange = Range(addr).Resize(1)
If Intersect(colRange, ActiveWindow.VisibleRange) Is Nothing Then
colRange.Select
ActiveWindow.Zoom = True
oldSel.Select
End If
End Sub
From the link i posted in the comment, i have come up with this code
Sub temp()
Dim zoomRatio As Integer
zoomRatio = 100
Do While (Not (CellIsInVisibleRange(ActiveSheet.Range("Z1"))))
zoomRatio = zoomRatio - 1
ActiveWindow.Zoom = zoomRatio
Loop
End Sub
Function CellIsInVisibleRange(cell As Range)
CellIsInVisibleRange = Not Intersect(ActiveWindow.VisibleRange, cell) Is Nothing
End Function
Update:
Revised the subroutine to Zoom in if more than column Z is visible and Zoom out if less than Col Z is visible
Sub temp()
Dim zoomRatio As Integer
zoomRatio = ActiveWindow.Zoom
Do While (Not (CellIsInVisibleRange(ActiveSheet.Range("Z1"))))
zoomRatio = zoomRatio - 2
ActiveWindow.Zoom = zoomRatio
Loop
Do While (CellIsInVisibleRange(ActiveSheet.Range("AA1")))
zoomRatio = zoomRatio + 2
ActiveWindow.Zoom = zoomRatio
Loop
End Sub
I fixed it. Thank you!
Private Sub Worksheet_Activate()
If CellIsInVisibleRange(ActiveSheet.Range("Z2")) Then
'Nothing
Else
Range("A2:Z2").Select
ActiveWindow.Zoom = True
Range("D3").Select
End If
End Sub
Function CellIsInVisibleRange(cell As Range)
CellIsInVisibleRange = Not Intersect(ActiveWindow.VisibleRange, cell) Is Nothing
End Function
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'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 have a combobox drop down that populates items from a list, with a function to filter to dropdown options by characters type in the combobox gathered by the following code
Option Explicit
Private cLstPrior As Variant
Private Sub Worksheet_SelectionChangePrior(ByVal Target As Range)
cLstPrior = Application.Transpose(Database.Columns("1:1").SpecialCells(xlCellTypeConstants, 23)) 'set module-level variable
Tool.priorCmb.List = cLstPrior 'initialize ComboBox to range Col A (UsedRange only)
Tool.priorCmb.ListIndex = -1 'set ComboBox value to empty
End Sub
Private Sub priorCmb_Change()
filterComboListPrior Tool.priorCmb, cLstPrior
End Sub
Private Sub priorCmb_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Tool.priorCmb.DropDown
End Sub
Private Sub priorCmb_GotFocus() 'or _MouseDown()
Tool.priorCmb.DropDown
End Sub
Public Sub filterComboListPrior(ByRef cmbPrior As ComboBox, ByRef dLstPrior As Variant)
Dim itmPrior As Variant, lstPrior As String, selPrior As String
Application.EnableEvents = False
With cmbPrior
selPrior = .Value
If IsEmpty(cLstPrior) Then cLstPrior = Worksheets("Database").Columns("1:1").SpecialCells(xlCellTypeConstants, 23)
For Each itmPrior In cLstPrior
If Len(itmPrior) > 1 Then If InStr(1, itmPrior, selPrior, 1) Then lstPrior = lstPrior & itmPrior & "||"
Next
If Len(lstPrior) > 1 Then .List = Split(Left(lstPrior, Len(lstPrior) - 2), "||") Else .List = dLstPrior
End With
Application.EnableEvents = True
End Sub
The data the combobox needs to populate with is all from Column 1 in this case, any cell with characters in it.
The issue is that there are blank cells at A1 and A2, so blank entries populate the combobox dropdown later on. I am trying to force the range to only include cells with values in them, but am getting an application-defined or object-defined error at If IsEmpty(cLstPrior) Then cLstPrior = Worksheets("Database").Columns("1:1").SpecialCells(xlCellTypeConstants, 23)
I can't seem to figure this out. Also, is my Application.Transpose behavior correct or not needed?
Instead of:
Database.UsedRange.Rows(2)
Try:
Database.Range(Database.Cells(2,2),Database.Cells(Database.UsedRange.Rows.Count, 2))
May be best to use specialcells, and loop through the cells that have values.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rRng As Range, c As Range, ws As Worksheet
Set ws = Sheets("Database")
Me.ComboBox1.Clear
Set rRng = ws.Rows("2:2").SpecialCells(xlCellTypeConstants, 23)
For Each c In rRng.Cells
Me.ComboBox1.AddItem c
Next c
End Sub
Use Intersect to exclude columns
With Worksheets("Database")
Set rng = Application.Intersect(.UsedRange.Rows(2), .Cells.Resize(.Columns.Count - 1).Offset(1))
End With
Change the line in question to the newly defined range
If IsEmpty(cLst) Then cLst = rng
Hye there.
I would like to ask for any ideas from anyone here.
I have a lot of checkboxes in a worksheet which I link with a chart in the same worksheet. I would like to make a function which run the same code for each of the checkboxes ( I have 24 check boxes overall) when it is click. If you have any idea or suggestion, do tell me.
Here is the idea of mine for the flow of the code. I just have the same flow of code.
Private Sub CheckBox1_Click()
On Error Resume Next
Sheets("REPORT").Activate
ActiveSheets.ChartObjects("STOCK MOVEMENT GRAPH").Activate
On Error GoTo 0
If CheckBox1.Value = False Then
ActiveChart.SeriesCollection(1).Delete
Else
ActiveChart.SeriesCollection.Add Source:=Sheets("REPORT").Range("B4:AB4")
End If
End Sub
Private Sub CheckBox2_Click()
On Error Resume Next
Sheets("REPORT").Activate
Worksheets("REPORT").ChartObjects("STOCK MOVEMENT GRAPH").Activate
On Error GoTo 0
If CheckBox2.Value = False Then
ActiveChart.SeriesCollection(2).Delete
Else
ActiveChart.SeriesCollection.Add Source:=Sheets("REPORT").Range("B5:AB5"), PlotBy:=xlRows
End If
End Sub
Thanks in advance. Regards.
You can pull out the common code into a standalone Sub:
Sub UpdateChart(rowNum As Long, AddingIt As Boolean)
Dim cht As Chart, s As Series, rng As Range, f, i
Set cht = Sheets("REPORT").ChartObjects("STOCK MOVEMENT GRAPH").Chart
'what's the data range?
Set rng = Sheets("REPORT").Range("B3").Offset(rowNum, 0).Resize(1, 2)
If AddingIt Then
'note: not checking if already added....
cht.SeriesCollection.Add Source:=rng
Else
For i = cht.SeriesCollection.Count To 1 Step -1
Set s = cht.SeriesCollection(i)
f = s.Formula
If InStr(f, rng.Address()) > 0 Then s.Delete
Next i
End If
End Sub
Then your checkbox code reduces to this:
Private Sub CheckBox1_Click()
UpdateChart 1, CheckBox1.Value
End Sub
Private Sub CheckBox2_Click()
UpdateChart 2, CheckBox2.Value
End Sub
'etc....
Option Explicit
Public PlotName As String
Public PlotRange As Range
Sub Tester()
Range("TCKWH.V.1").Select
AddPlot ActiveSheet.Range("KWH_G_1")
End Sub
Sub AddPlot(rng As Range)
With ActiveSheet.Shapes.AddChart
PlotName = .Name
.Chart.ChartType = xlLineMarkers
.Chart.SetSourceData Source:=Range(rng.Address())
.Chart.HasTitle = True
.Chart.ChartTitle.Text = Range("KWH.G.1")
.Chart.Axes(xlValue, xlPrimary).HasTitle = True
.Chart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = Range("KWH.G.1")
End With
Set PlotRange = rng
Application.EnableEvents = False
rng.Select
Application.EnableEvents = True
End Sub
Sub FixPlott(rng As Range)
Dim n As Long
With ActiveSheet.Shapes(PlotName)
For n = .SeriesCollection.Count To 1 Step -1
With .SeriesCollection(n)
If PlotName = "" Then
.Delete
End If
End With
Next n
End With
End Sub
Sub RemovePlot(rng As Range)
If Not PlotRange Is Nothing Then
If Application.Intersect(rng, PlotRange) Is Nothing Then
On Error Resume Next
rng.Parent.Shapes(PlotName).Delete
On Error GoTo 0
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
RemovePlot Target
Application.ScreenUpdating = True
End Sub
I need help with Sub FixPlott. I am trying to get it to delete the Legend Entries on the Legend Key. For example if I select Main Campus and South Hall there will be blank legend entries for dunblane and greensburg. Id like the legend just to show selected buildings.
Here you have a corrected version of your sub:
Sub FixPlott(PlotName As String)
Dim n As Long
With ActiveSheet.Shapes(PlotName).Chart
For n = .SeriesCollection.Count To 1 Step -1
With .SeriesCollection(n)
If .Name = "" Then
ActiveSheet.Shapes(PlotName).Chart.Legend.LegendEntries(n).Delete
End If
End With
Next n
End With
End Sub
I am not sure about the exact trigger you want to use. So I have included a simple string trigger; if the given SeriesCollection is called like trigger, the legend will be deleted.