Is it possible to have just the drop down menu of a ComboBox in a UserForm autofit to the text size, without changing the actual size of the ComboBox?
I've found some answers on how to autofit the actual ComboBox based on the values within, but that makes the size bigger than I actually want (link here).
The following image somewhat represents what I'm trying to accomplish:
Does anyone know if this is even possible?
Some of the columns seem a little wide, but over all I think the code does a pretty good job of configuring the drop down.
Private Sub ConfigureComboBox()
Dim arrData, arrWidths
Dim x As Long, y As Long, ListWidth As Double
arrData = ComboBox1.List
ReDim arrWidths(UBound(arrData, 2))
For x = 0 To UBound(arrData, 1)
For y = 0 To UBound(arrData, 2)
If Len(arrData(x, y)) > arrWidths(y) Then arrWidths(y) = Len(arrData(x, y))
Next
Next
For y = 0 To UBound(arrWidths)
arrWidths(y) = arrWidths(y) * ComboBox1.Font.Size
ListWidth = ListWidth + arrWidths(y)
Next
With ComboBox1
.ColumnCount = UBound(arrWidths) + 1
.ColumnWidths = Join(arrWidths, ";")
.ListWidth = ListWidth
End With
End Sub
Sample data from Excel Sample Data
Me.ComboBox1.ListWidth = 200 'Custom size
Related
I am very new to VBA. I am trying to calculate the rolling means of a range, I certain my mistake is something very silly
Function Rolling_Mean(Prices as Range)
Dim window as Long, i As Integer, temp_sum as Long
Dim means() as Long
window = 10
temp_sum = 0
ReDim means(1 to 253)
For i = 1 to 253
temp_sum = temp_sum + Prices(i)
If i Mod window = 0 Then
means(i) = temp_sum / 10
temp_sum = 0
End If
Next
Rolling_Mean = means
End Function
I keep getting an error or an array of 0s. I think my issue is how im trying to access the Prices. I am also wondering how to implement the syntax AVERAGE(Prices(1) to Prices(10)) as that would help a lot as well.
This will be run in the sheet with =Rolling_Mean(B2:B253)
This seems to work for me. Added the window as a second parameter.
Function Rolling_Mean(Prices As Range, window As Long)
Dim i As Long, sum As Double
Dim means(), data
data = Prices.Value 'assuming a single column of cells....
ReDim means(1 To UBound(data, 1), 1 To 1)
For i = 1 To UBound(data, 1)
sum = sum + data(i, 1)
If i >= window Then
means(i, 1) = sum / window
sum = sum - data(i - window + 1, 1) 'subtract value from trailing end of window
Else
means(i, 1) = ""
End If
Next i
Rolling_Mean = means
End Function
If your Excel version doesn't have "auto spill" then you'll need to enter it as an array formula (Ctrl+Shift+Enter)
I need the values from a multi-select list-box to populate into different locations within a spreadsheet. Each selection needs to populate on a different row i.e. 1st selection B60, 2nd selection B68, 3rd selection B78.
I tried adding the below code to what I have, but get "Without if" error and "Next For" error:
I tried adding:
If Me.ALLAC.Selected(x) Then
Ck = 2
addme = Me.ALLAC.List(x)
addme.Offset(8, 1) = Me.ALLAC.List(x, 1)
addme.Offset(8, 2) = Me.ALLAC.List(x, 2)
Set addme = addme.Offset(1, 0)
Below is the current code as written
Private Sub cmdAdd2_Click()
'dimension the variable
Dim addme As Range
Dim x As Integer, Ck As Integer
'set variables
Set addme = sheet9.Range("B59").Offset(1, 0)
Ck = 0
'run the for loop
For x = 0 To Me.ALLAC.ListCount - 1
'add condition statement
If Me.ALLAC.Selected(x) Then
Ck = 1
addme = Me.ALLAC.List(x)
addme.Offset(0, 1) = Me.ALLAC.List(x, 1)
addme.Offset(0, 2) = Me.ALLAC.List(x, 2)
Set addme = addme.Offset(1, 0)
'clear the selected row
ALLAC.Selected(x) = False
End If
Next x
'send a message if nothing is selected
If Ck = 0 Then
MsgBox "There is nothing selected"
End If
End Sub
I'd like to see each selection in the multi-select list to go to specific cells within my spreadsheet.
But they are showing up one row after the next. i.e. B60, B61, B62.
I changed the Set addme=addme.offset (8,0) to move the second and third clicks down 8 rows from my first click. Perfect, simple fix, no more code needed. I was putting more into it then needed. Thank you Pawel for your input.
I'm trying to import a picture to excel cell and I'm facing issues with re-sizing.
Steps:
Copy/Paste the picture to the cell
Re-size the picture manually
And also resize the cell to fix on the picture.
Is there any other way to do it instead of manually?
I'm not sure what exactly you meant with re size the picture manually, but might this be working for you?
Sub ResizeCells()
Dim X As Double, Y As Double, Z As Double
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Type = msoPicture Then
For X = s.TopLeftCell.Column To s.BottomRightCell.Column
Y = Y + ActiveSheet.Cells(1, X).ColumnWidth
Next X
For X = s.TopLeftCell.Row To s.BottomRightCell.Row
Z = Z + ActiveSheet.Cells(1, X).RowHeight
Next X
s.TopLeftCell.ColumnWidth = Y
s.TopLeftCell.RowHeight = Z
End If
Next s
End Sub
Note:
Max RowHeight is 409
Max ColumnWidth is 255
This goes the other way.
We will insert a Shape from the Internet.
We will move it to cell B1.
We will resize the Shape (both height and width) to fit in B1First place this link in cell A1:
http://www.dogbreedinfo.com/images26/PugPurebredDogFawnBlackMax8YearsOld1.jpg
Then run:
Sub MAIN()
Call InstallPicture
Call PlaceAndSizeShape
End Sub
Sub InstallPicture()
Dim v As String
v = Cells(1, 1).Value
With ActiveSheet.Pictures
.Insert (v)
End With
End Sub
Sub PlaceAndSizeShape()
Dim s As Shape, B1 As Range, w As Double, h As Double
Set s = ActiveSheet.Shapes(1)
s.Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Set B1 = Range("B1")
s.Top = B1.Top
s.Left = B1.Left
s.Height = B1.Height
s.Width = B1.Width
End Sub
This post is old, but nobody mentioned resizing the picture to match the cell.
Excel is very unreliable when I tired to scale the width using #Andrew's code. Luckily, rCell.Left is in the correct units. You can get the actual column width using:
rCell.Offset(0, 1).Left - rCell.Left
This Code will Resize the Cell to Your Picture
Sub ResizePictureCells()
For Each Picture In ActiveSheet.DrawingObjects
PictureTop = Picture.Top
PictureLeft = Picture.Left
PictureHeight = Picture.Height
PictureWidth = Picture.Width
For N = 2 To 256
If Columns(N).Left > PictureLeft Then
PictureColumn = N - 1
Exit For
End If
Next N
For N = 2 To 65536
If Rows(N).Top > PictureTop Then
PictureRow = N - 1
Exit For
End If
Next N
Rows(PictureRow).RowHeight = PictureHeight
Columns(PictureColumn).ColumnWidth = PictureWidth * (54.29 / 288)
Picture.Top = Cells(PictureRow, PictureColumn).Top
Picture.Left = Cells(PictureRow, PictureColumn).Left
Next Picture
End Sub
Everyone,
I'm trying to automated my excel file to choose random data to check for audit. I want to make randomizer that I can input how many data to select. is that possible in excel? I put some screenshot below for better explanation. I hope you can help me.
Using the usual excel functions this is indeed impossible...
However, excel (and the other Microsoft office applications) run an underlying programming language: visual basic. That's the way to go :)
Here's a makro, that selects a random field matching the search in the whole column.
Sub SelectRandomSearch()
'Declaring Variables
Dim y As Integer
Dim x As Integer
Dim startY As Integer
Dim lastY As Integer
Dim search As String
Dim hits As Integer
Dim random As Integer
Dim hitsArr() As Integer
Dim controlPart As Double
Dim controlsNum As Integer
Dim controlArr() As Integer
'Declaring Values
startY = 1 'lowest Y-Coordianate of the input column
x = 1 'X-Coordiante of the input column
controlPart = 0.1 'Fraction of the hits, that need to be controled
'Get search value
search = InputBox("Enter a search value", "Searching", "")
'Getting Column Lenght and reset coloring
y = startY
Do Until IsEmpty(Cells(y, x).Value)
Cells(y, x).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
y = y + 1
Loop
'Getting number of search hits
lastY = y - 1
hits = WorksheetFunction.CountIf(Range(Cells(startY, x), Cells(lastY, x)), search)
'Fill hitsArr with row-numbers of hits
ReDim hitsArr(hits + 1)
hits = 1
For y = startY To lastY
If Cells(y, x) = search Then
hitsArr(hits) = y
hits = hits + 1
End If
Next y
hits = hits - 1
'Getting number of controlled Entries
controlsNum = WorksheetFunction.RoundUp(hits * controlPart, 0)
'Shuffle a part of hitsArr
ReDim controlArr(controlsNum + 1)
For y = 1 To controlsNum
random = ((hits - y + 1) * Rnd + y)
hitsArr(0) = hitsArr(y)
hitsArr(y) = hitsArr(random)
hitsArr(random) = hitsArr(0)
Next y
'Mark every hit that needs to be controlled
For y = 1 To controlsNum
Cells(hitsArr(y), x).Select
With Selection.Interior
.Color = 49407
End With
Next y
End Sub
You probably need to change the makro slightly, but this basicly does all I can think of you could need :)
I hope this helps!
Now the makro marks the fields that need to be checkt like this:
I have been banging my head (and a few other heads as well on other Excel programming sites) to get a Combobox in a Userform to sort the rows (coming from two columns in the source spreadsheet) in alpha order.
Ideally, I want a 2 dimensional sort, but at this point, will settle for ONE that works.
Currently, the Combobox, when dropped down, reads in part (minus the bullet points, which do NOT appear and are not needed):
Zoom MRKPayoutPlan
Chuck PSERSFuture
Chuck PSERSCurrent
What I want is:
Chuck PSERSCurrent
Chuck PSERSFuture
Zoom MRKPayoutPlan
The first order is derived from the order in which the rows appear in the source worksheet.
At this point, I am getting a Runtime Error '13', Type Mismatch error. Both fields are text fields (one is last name, the other is a classification code- I want to sort first by name).
Below are the two relevant sections of the VBA code. If someone can help me sort this out, I'll buy at least a virtual round of beers. Excel VBA is not my most comfortable area- I can accomplish this in other apps, but the client spec is that this all must run in Excel alone. Thanks in advance.
Private Sub UserForm_Initialize()
fPath = ThisWorkbook.Path & "\"
currentRow = 4
sheetName = Sheet5.Name
lastRow = Sheets(sheetName).Range("C" & Rows.Count).End(xlUp).Row
Dim rngUID As Range
Dim vList
Set rngUID = Range("vUID")
With rngUID
vList = Application.Index(.Cells, .Parent.Evaluate("ROW(" & .Address & ")"), Array(7, 1))
End With
vList = BubbleSort2D(vList, 2, 1)
With ComboBox1
.ColumnCount = 2
.ColumnWidths = "100;100"
.List = vList
End With
PopulateControls
End Sub
Public Function BubbleSort2D(Strings, ParamArray SortColumns())
Dim tempItem
Dim a As Long
Dim e As Long
Dim f As Long
Dim g As Long
Dim i As String
Dim j As String
Dim m() As String
Dim n
Dim x As Long
Dim y As Long
Dim lngColumn As Long
e = 1
n = Strings
Do While e <> -1
For a = LBound(Strings) To UBound(Strings) - 1
For y = LBound(SortColumns) To UBound(SortColumns)
lngColumn = SortColumns(y)
i = n(a, lngColumn)
j = n(a + 1, lngColumn)
f = StrComp(i, j)
If f < 0 Then
Exit For
ElseIf f > 0 Then
For x = LBound(Strings, 2) To UBound(Strings, 2)
tempItem = n(a, x)
n(a, x) = n(a + 1, x)
n(a + 1, x) = tempItem
Next x
g = 1
Exit For
End If
Next y
Next a
If g = 1 Then
e = 1
Else
e = -1
End If
g = 0
Loop
BubbleSort2D = n
End Function
Here is a bubble sort in VBA source.
Public Sub BubbleSort(ByRef sequence As Variant, _
ByVal lower As Long, ByVal upper As Long)
Dim upperIt As Long
For upperIt = upper To lower + 1 Step -1
Dim hasSwapped As Boolean
hasSwapped = False
Dim bubble As Long
For bubble = lower To upperIt - 1
If sequence(bubble) > sequence(bubble + 1) Then
Dim t as Variant
t = sequence(bubble)
sequence(bubble) = sequence(bubble + 1)
sequence(bubble + 1) = t
hasSwapped = True
End If
Next bubble
If Not hasSwapped Then Exit Sub
Next upperIt
End Sub
Note that using variable names that specify what they are and do instead of single letters makes it easier to read.
As for the 2D sort. Don't. Sort each array individually then sort the array of arrays using the same method. You will need to provide an abstraction to compare the columns. Do not try to sort them both at the same time. I can't think of a scenario where that is a good idea. If for some reason elements can change their sub array in the 2D array, then flatten it into 1 array, sort that and split it back into a 2D array.
Honestly from what I am understanding of you specific problem. You are going from 1D sequence to a 1D sequence so I think 2D arrays are and unnecessary complication.
Instead use a modified bubble sort routine with the comparison statement,
If sequence(bubble) > sequence(bubble +1) Then '...
replaced with a custom comparison function
ComboBoxItemCompare(sequence(bubble), sequence(bubble + 1))
that will return True if the first argument should be swapped with the second.