Adjust Listbox.Height problems - excel

I have a userform with a textbox and a listbox with the following plan:
Users input text in Textbox1.
Every time Textbox1.Text changes, a search with the following features is performed:
Textbox1.Text is searched in a specific range in a worksheet.
Textbox1.Text can be found more than once.
Listbox1 is populated with the results of the search.
So far so good. Due to having large set of data, the list can get many items. In this case the list reaches out of the screen and I had to limit Listbox1.Height. This is the code for the above:
Private Sub TextBox1_Change()
Dim srchWord As String, firstAddress As String
Dim srchRng As Range, cell As Range
Dim maxRow As Integer
ListBox1.Clear
If TextBox1.Value = "" Then
ListBox1.Height = 0
Else
With ThisWorkbook.Worksheets(1)
maxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set srchRng = .Range("A2:A" & maxRow)
End With
srchWord = TextBox1.Value
Set cell = srchRng.Find(srchWord, LookIn:=xlValues, lookat:=xlPart)
With ListBox1
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If Not cell.Value Like "*(*" Then
.AddItem (cell.Value)
Select Case .ListCount
Case Is < 2
.Height = 17
Case Is < 21
.Height = 15 * .ListCount
Case Else
.Height = 272.5
End Select
Me.Height = 500
End If
Set cell = srchRng.FindNext(cell)
Loop While Not cell.Address = firstAddress
End If
End With
End If
End Sub
The problem was in Case Else when scroll was enabled I couldn't reach the last item of the list. By searching on the net I found some potential solutions:
set Listbox1.IntegralHeight = False set the height and then set again Listbox1.IntegralHeight = True
set Listbox1.MultiSelect = fmMultiSelectSingle and then set again Listbox1.MultiSelect = fmMultiSelectExtended.
do both of the above.
Application.Wait (Now + TimeValue("0:00:01") * 0.5) and then set the height.
None of these worked.
To be able to scroll to the last item, this worked:
Listbox1.IntegralHeight = False
Listbox1.Height= x
Listbox1.IntegralHeight = False
Listbox1.Height= x
but this also set the Listbox1.Height to this of one single item. (with arrows at the right)
Does anybody know how on earth am I going to control the Listbox1.Height without all this unwanted behaviour? Also if somebody can suggest another structure that could follow the plan mentioned at first, I 'm willing to discard the listbox.

This seems to be a not completely explored behaviour.
In my experience just redefine some listbox arguments.
Try the recommended sets of .IntegralHeight to False and True.
Another possible measure can help in some cases: try to choose heights for your listbox that come close to the following multiplication:
listbox height = (font size + 2 pts) * (maximum items per page)
Insert the following code after With ListBox1:
With ListBox1
.Top = 18 ' << redefine your starting Point
.Font.Size = 10 ' << redefine your font size
.IntegralHeight = False ' << try the cited recommendation :-)
Insert the following code before End With:
.Height = .Height + .Font.Size + 2
.IntegralHeight = True
End With
Hope that helps.
Link
See another faster approach to filter listboxes at How to speed up filling of listbox values on userform excel

#T.M.: Thank you for your quick response and for your time. Your answer gave me exactly what I wanted and that's why I'm marking it as such. I'm posting this just for future reference.
What I finaly did to implement the plan.
First of all I inserted:
this
With ListBox1
.Top = 18
.Font.Size = 10
.IntegralHeight = False
and this
.Height = .Height + .Font.Size + 2
.IntegralHeight = True
End With
and I linked .Height with .Font.Size as you suggested. As long as there was no need to assign absolute values to the height, there was no need to have a Select Case statement in my code.
Moreover I realized that there was no need to change the height every time an item was added but only at the end of the process, so I took it out of the loop.
Finally I added a piece of code that would make the list invisible when Textbox1 was empty. The code is now like this:
Final Userform code:
Option Compare Text
Option Explicit
Private bsdel As Boolean 'indicates if backspace or delete keys have been hit.
Private Sub ListBox1_Click()
Dim cell As Range
Dim maxRow As Integer
With ThisWorkbook.Worksheets(1)
maxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set cell = .Range("A1:A" & maxRow).Find(UserForm11.ListBox1.Text, LookIn:=xlValues, lookat:=xlWhole)
If Not cell Is Nothing Then
cell.Select
'do other stuff also.
End If
End With
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
bsdel = False
If KeyCode = 8 Or KeyCode = 46 Then _
bsdel = True
End Sub
Private Sub TextBox1_Change()
Dim srchWord As String, firstAddress As String
Dim srchRng As Range, cell As Range
Dim maxRow As Integer
ListBox1.Clear
ListBox1.Visible = True
If bsdel And TextBox1.Value = "" Then
ListBox1.Visible = False
Me.Height = 130
Else
With ThisWorkbook.Worksheets(1)
maxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set srchRng = .Range("A1:A" & maxRow)
End With
srchWord = TextBox1.Value
Set cell = srchRng.Find(srchWord, LookIn:=xlValues, lookat:=xlPart)
With ListBox1
'.Top = 84 'test made: deleting this made no difference.
'.Font.Size = 10 'test made: deleting this made no difference.
.IntegralHeight = False
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If Not cell.Value Like "*(*" Then 'this range includes notes within parenthesis and I didn't need them.
.AddItem (cell.Value)
End If
Set cell = srchRng.FindNext(cell)
Loop While Not cell.Address = firstAddress
If .ListCount < 21 Then 'the size is adjusted.
.Height = (.Font.Size + 2) * .ListCount
Else 'the size stays fixed at maximum.
.Height = (.Font.Size + 2) * 20
End If
End If
Me.Height = .Height + 130
.Height = .Height + .Font.Size + 2
.IntegralHeight = True
End With
End If
bsdel = False
End Sub
Private Sub UserForm_Activate()
TextBox1.SetFocus
End Sub
Private Sub UserForm_Initialize()
ListBox1.Visible = False
End Sub

Related

VBA Userform posting data twice....sometimes

I have a userform with a combobox on a sheet "PostHistory" that draws it's data from the "Staff" sheet. When you press Add on the userform it's suppose to locate the name on the Staff Sheet and replace the date next to the name. Occasionally, it will replace the date and the date next to the name below it. Using Excel 2016
Private Sub CommandButton7_Click()
Application.ScreenUpdating = False
Sheets("Staff").Visible = True
Sheets("Engine").Visible = True
Dim TargetRow As Integer
Dim nameRange As Range
Set nameRange = Sheets("Staff").Range("C3:C200")
TargetRow = Sheets("Engine").Range("D3").Value
Sheets("PostHistory").Range("B3").EntireRow.Insert Shift:=xlDown
Sheets("PostHistory").Range("B3").Value = txt_date
Sheets("PostHistory").Range("C3").Value = cb_staff
Sheets("PostHistory").Range("D3").Value = txt_post
Sheets("PostHistory").Range("E3").Value = txt_notes
If (Augment.txt_date.Text) = "" Then
GoTo Skip1
ElseIf IsNull(Augment.txt_date.Value) = False Then
End If
For Each cell In nameRange.Cells
If cell.Text = [cb_staff] Then
cell.Offset(0, -1).Value = txt_date
End If
Next
Skip1:
Unload Augment
Sheets("Staff").Visible = False
Sheets("Engine").Visible = False
Sheets("List").Visible = False
Application.ScreenUpdating = True
Augment.Show
End Sub
To start: I didn't find the reason why your code should write more than once. But I believe the code below will not write anything twice.
Private Sub CommandButton7_Click()
' 209
Dim nameRange As Range
Dim Fnd As Range
Dim Ctls() As String
Dim i As Integer
Ctls = Split("txt_Date,cb_Staff,txt_Post,txt_Notes", ",")
If Len(txt_Date) Then
With Worksheets("Staff")
Set nameRange = .Range(.Cells(3, 3), .Cells(.Rows.Count, 3).End(xlUp))
End With
Set Fnd = nameRange.Find(cb_Staff.Value, , xlValues, xlWhole)
If Not Fnd Is Nothing Then Fnd.Offset(0, -1).Value = txt_Date.Value
End If
With Worksheets("PostHistory")
.Rows(3).EntireRow.Insert Shift:=xlDown
With .Rows(3)
For i = 0 To UBound(Ctls)
.Cells(3 + i).Value = Me.Controls(Ctls(i)).Value
Me.Controls(Ctls(i)).Value = ""
Next i
End With
End With
End Sub
In principle, you don't need to unhide a sheet in order to read from or write to it. Also, if the sheet to which you write is hidden, there is no point in stopping ScreenUpdating. Finally, I did like the way you found to clear all controls but believe that it will interfere with your management of the list in the combo box. Therefore I showed you another method above.
Oh, yes. I created a userform called Augment with one combo box, 3 text boxes and one CommandButton7. I hope that is what you also have.

Autofit Zoom View to active/visible cells in table?

I wasn't able to find any vba zoom except for auto-changing based on resolution, but is it possible to autofit custom zoom level based on most furthest out column that has text?
Sub Workbook_Open()
ActiveWindow.Zoom = 100 'also you can change to other size
End Sub
Bonus Code:
To reset the scroll bar to far left, so it's looking at Column A/Row1, this code works :) I have it on a "reset" userbutton.
'Scroll to a specific row and column
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Thank you in advance.
Try this code:
Function FindFurthestColumn(S As Worksheet) As Integer
Dim CellsWithContent As Long
CellsWithContent = WorksheetFunction.CountA(S.Cells)
If CellsWithContent = 0 Then
FindFurthestColumn = 1
Exit Function
End If
Dim CellsCount As Long
Dim j As Integer
Do
j = j + 1
CellsCount = CellsCount + WorksheetFunction.CountA(S.Columns(j))
Loop Until CellsCount = CellsWithContent
FindFurthestColumn = j
End Function
Function CellIsVisible(cell As Range) As Boolean
CellIsVisible = Not Intersect(ActiveWindow.VisibleRange, cell) Is Nothing
End Function
Sub ZoomVisibleCells()
Application.ScreenUpdating = False
Dim LastColumn As Integer
LastColumn = FindFurthestColumn(ActiveSheet)
Dim SplitCell As Range
If ActiveWindow.Split = True Then
Set SplitCell = Cells(ActiveWindow.SplitRow + 1, ActiveWindow.SplitColumn + 1)
ActiveWindow.FreezePanes = False
End If
Dim Zoom As Integer
For Zoom = 400 To 10 Step -1
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
ActiveWindow.Zoom = Zoom
If CellIsVisible(ActiveSheet.Cells(1, LastColumn + 1)) Then
Exit For
End If
Next Zoom
If Not SplitCell Is Nothing Then
SplitCell.Activate
ActiveWindow.FreezePanes = True
End If
Application.ScreenUpdating = True
End Sub
Credit for the CellIsVisible function:
https://stackoverflow.com/a/11943260/14370454
AUTO ZOOM RESPONSIVE VIEW EXCEL VBA CODE
In a sheet type any character on cell A1 and your last column view then type a character on first row with last column. That's it, see a magic of responsive view Excel sheet/s.
Note: copy this code and paste it to Thisworkbook module.
Thank you all.
Private Sub Workbook_WindowResize(ByVal Wn As Window)
Dim LastCol As Long
Dim rng As Range
Dim x As Integer
Dim y As Integer
With ActiveSheet
Set rng = .Rows(1).Find(What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
End With
If Not rng Is Nothing Then
LastCol = rng.Column
Else
LastCol = 1
End If
x = 1 ' For First Column
y = LastCol ' For Last
Columns(Chr(64 + x) & ":" & Chr(64 + y)).Select
ActiveWindow.Zoom = True
ActiveSheet.Range("E1").Select
End Sub

Conditional insert of page breaks

I have a form that is changing all the time and I have boxes of text in column "C". Also some text in cells of column "C" is too long so I am wrapping it with my VBA. I want to make conditional page breaks that will read through my Print Area and insert page breaks after each empty row before heading. My VBA code below is working fine except for text being wrapped. So the problem is: If I set PgSize = 91 in Sub FitGroupsToPage() (that's an amount of rows could be fitted to each page) to 91 and don't wrap my text then everything works fine. However text must be wrapped to fit to my page. Then there is not 91 rows but less, according to the length of the text in wrapped cells. So number 91 is dynamic each time after hiding and wrapping Sub FitMyTextPlease() and Sub HideMyEmptyRows() and Sub SetPrintArea(). Number of rows can also be different on every page (depending of how much text there are wrapped on each page). Any ideas of how this issue can be fixed?
Sub FitMyTextPlease()
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Print version").PageSetup.CenterHeader = "&""Times New Roman,Bold""&12 " & Range("Data!V28").Text & Chr(13) & Chr(13) & " " & "&""Times New Roman,Normal""&12 " & Range("Data!V30").Text
'ThisWorkbook.Sheets("Print version").PageSetup.CenterHeader = Range("Data!V28").Text
ThisWorkbook.Sheets("Print version").Select
With ActiveWorkbook.ActiveSheet
With .Cells.Rows
.WrapText = True
.VerticalAlignment = xlCenter
.EntireRow.AutoFit
End With '.Cells.Rows
.Columns.EntireColumn.AutoFit
End With 'sheet
Application.ScreenUpdating = True
End Sub
Sub HideMyEmptyRows()
Dim myRange As Range
Dim cell As Range
Application.ScreenUpdating = False
Set myRange = ThisWorkbook.Sheets("Print version").Range("Print_Area")
For Each cell In myRange
myRange.Interior.ColorIndex = 0
If cell.HasFormula = True And cell.value = "" And cell.EntireRow.Hidden = False Then Rows(cell.Row).EntireRow.Hidden = True
Next
Application.ScreenUpdating = True
End Sub
Sub SetPrintArea()
Dim ws As Worksheet
Dim lastrow As Long
Set ws = ThisWorkbook.Sheets("Print version")
' find the last row with formatting, to be included in print range
lastrow = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
ws.PageSetup.PrintArea = ws.Range("A1:C" & lastrow).Address
End Sub
Sub Printed_Pages_Count()
Range("A1").value = (ActiveSheet.HPageBreaks.Count + 1) * (ActiveSheet.VPageBreaks.Count + 1)
End Sub
Sub FitGroupsToPage()
Dim rStart As Range, rEnd As Range, TestCell As Range
Dim lastrow As Long, PgSize As Integer
Dim n As Integer
PgSize = 91 ' Assumes 91 rows per page
Set rStart = Range("C1")
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Do
Set TestCell = rStart.Offset(PgSize, 0)
If Len(TestCell) = 0 Or Len(TestCell.Offset(-1, 0)) = 0 Then
Set rEnd = TestCell.End(xlUp)
Else
Set rEnd = TestCell.End(xlUp).End(xlUp)
End If
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=rEnd.Offset(1, 0)
Set rStart = rEnd.Offset(1, 0)
n = n + 1
If n > 1000 Then Exit Sub ' Escapes from an infinite loop if code fails
Loop Until rStart.Row > lastrow - 50
End Sub
Sub FitMyHeadings()
Call FitMyTextPlease
Call HideMyEmptyRows
Call SetPrintArea
Call FitGroupsToPage
Call Printed_Pages_Count
End Sub
If standard row height is 15, then for 91 rows the total row height would be 1365. When text wraps one line, the row height becomes 30. So what you might try doing is defining 1365 as the total row height per page before inserting a break instead of 91 as the total number of rows.
You can determine the row height with Range("A1").RowHeight

Creating a Multi Selection Checkbox List in Side-by-Side Cell Across Row in Excel

I'm using VB code created by L42 on 4/27/14 that creates a checkbox list in a single cell.
Option Explicit
Dim fillRng As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBobj As OLEObject
Dim i As Long
Set LBobj=Me.OLEObjects("LB_Colors")
Set LBColors = Target
If Not Intersect(Target, [B2]) Is Nothing Then
Set fillRng = Target
With LBobj
.Left = fillRng.Left
.Top = fillRng.Top
.Width = fillRng.Width
.Visible = True
End With
Else
LBobj.Visible = False
If Not fillRng Is Nothing Then
fillRng.ClearContents
With LBColors
If .ListCount <> 0 Then
For i = 0 To .ListCount -1
If fillRng.Value = Then
If .Selected(i) Then fillRng.Value = .List(i)
Else
If .Selected(i) Then fillRng.Value = _
fillRng.Value & "," & .List(i)
End If
Next
End With
Set fillRng = Nothing
End If
End If
End Sub
The code works perfectly and I was able to extend the checkbox list to the cells in complete column by changing the (Target, [B1:B40]). Following this logic, I thought that I could extend checkboxes C and D columns by (Target, [B1:D40]. However, after selecting desired items in B column and clicking or tabing over to C column, the entire checkbox moves with selected items without writing in the previous cell. I would like to be able to tab over or click to the next cell in the row and have same checkbox items that populates that cell with item selected, independent of the previous cell. Then tab or click to succeeding cells and do the same and have cells retain and display selected the items. Can this code be modified to do that?
Thank you.
to always put the values in the cell, just change your code to something like this:
Option Explicit
Dim fillRng As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBobj As OLEObject
Dim i As Long
Set LBobj = Me.OLEObjects("LB_Colors")
Set LBColors = Target
LBobj.Visible = False
If Not fillRng Is Nothing Then
fillRng.ClearContents
With LBColors
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If .Selected(i) Then
If fillRng.Value = "" Then
fillRng.Value = .List(i)
Else
fillRng.Value = fillRng.Value & "," & .List(i)
End If
End If
Next
End If
End With
Set fillRng = Nothing
End If
If Not Intersect(Target, [B1:D40]) Is Nothing Then
Set fillRng = Target
With LBobj
.Left = fillRng.Left
.Top = fillRng.Top
.Width = fillRng.Width
.Visible = True
End With
End If
End Sub

Alternate Row Colors in Range

I've come up with the following to alternate row colors within a specified range:
Sub AlternateRowColors()
Dim lastRow as Long
lastRow = Range("A1").End(xlDown).Row
For Each Cell In Range("A1:A" & lastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
Cell.Interior.ColorIndex = 15 ''color to preference
Else
Cell.Interior.ColorIndex = xlNone ''color to preference or remove
End If
Next Cell
End Sub
That works, but is there a simpler method?
The following lines of code may be removed if your data contains no pre-exisiting colors:
Else
Cell.Interior.ColorIndex = xlNone
I need to do this frequently and like to be able to easily modify the colors I'm using for the banding. The following sub makes it very easy:
Sub GreenBarMe(rng As Range, firstColor As Long, secondColor As Long)
rng.Interior.ColorIndex = xlNone
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=0"
rng.FormatConditions(1).Interior.Color = firstColor
rng.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)<>0"
rng.FormatConditions(2).Interior.Color = secondColor
End Sub
Usage:
Sub TestGreenBarFormatting()
Dim rng As Range
Dim firstColor As Long
Dim secondColor As Long
Set rng = Range("A1:D12")
firstColor = vbGreen
secondColor = vbYellow
Call GreenBarMe(rng, firstColor, secondColor)
End Sub
Alternating row colors can be done using conditional formatting:
I needed a macro that would color every second row in a range, using only those rows that were visible. This is what I came up with. You don't have to loop through the rows.
Sub Color_Alt_Rows(Rng As Range)
Application.ScreenUpdating = False
Rng.Interior.ColorIndex = xlNone
Rng = Rng.SpecialCells(xlCellTypeVisible)
Rng.FormatConditions.Add Type:=xlExpression, Formula1:="=mod(row()+1,2)"
Rng.FormatConditions(1).Interior.ColorIndex = 34
End Sub
Try it out with Color_Alt_Rows Range("a2:d5")
My Solution
A subroutine to assign to a button or some code
Public Sub Band_Goals()
'Just pass the start and end rows
'You will have to update the function to select the
'the correct columns
BandRows_Invisble 12, 144
End Sub
The Function
Private Sub BandRows_Invisble(StartRow As Integer, EndRow As Integer)
Dim i As Long, nothidden As Boolean
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("A" & StartRow & ":K" & EndRow).Interior.ColorIndex = xlNone
For i = StartRow To EndRow
If Not Rows(i).Hidden Then
nothidden = nothidden + 1
If Not nothidden Then
'Download this app to help with color picking
'http://www.iconico.com/download.aspx?app=ColorPic
Range("A" & i & ":K" & i).Interior.Color = RGB(196, 189, 151)
End If
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
'--- Alternate Row color, only non-hidden rows count
Sub Test()
Dim iNumOfRows As Integer, iStartFromRow As Integer, iCount As Integer
iNumOfRows = Range("D61").End(xlDown).Row '--- counts Rows down starting from D61
For iStartFromRow = 61 To iNumOfRows
If Rows(iStartFromRow).Hidden = False Then '--- only non-hidden rows matter
iCount = iCount + 1
If iCount - 2 * Int(iCount / 2) = 0 Then
Rows(iStartFromRow).Interior.Color = RGB(220, 230, 241)
Else
Rows(iStartFromRow).Interior.Color = RGB(184, 204, 228)
End If
End If
Next iStartFromRow
End Sub
Well, you can delete the else part, since you will leave it in the default color
In my Excel 2010, there is an option to format as table, where you can also select a range and headers. No need for scripting.
set these up initialized somewhere:
Dim arr_Lng_Row_Color(1) As Long
arr_Lng_Row_Color(0) = RGB(int_Color_1_R, int_Color_1_G, int_Color_1_B)
arr_Lng_Row_Color(1) = RGB(int_Color_2_R, int_Color_2_G, int_Color_2_B)
On any row you wish this will set the color
ws_SomeSheet.Rows(int_Target_Row).EntireRow.Interior.Color = arr_Lng_Row_Color(int_Target_Row Mod 2)

Resources