Private Sub TextBox1_Change()
FontToFit TextBox1
End Sub
Sub FontToFit(txtBoxToFit As MSForms.TextBox)
Dim oHeight As Single, oWidth As Single
With TextBox1
oHeight = .Height: oWidth = .Width
.AutoSize = True: .AutoSize = False
Do Until (oHeight <= .Height) And (oWidth <= .Width)
.Font.Size = .Font.Size + 1
.AutoSize = True: .AutoSize = False
Loop
Do Until (.Height <= oHeight) And (.Width <= oWidth)
.Font.Size = .Font.Size - 1
.AutoSize = True: .AutoSize = False
Loop
.Height = oHeight: .Width = oWidth
End With
End Sub