'ラベルで分数を表示するサンプルマクロ(Excel97) '標準モジュールに以下のコードをコピーして 'MakeFormマクロを実行してください。 Option Explicit Sub MakeForm() Dim oVBComponent As Object Dim s As String s = "Option Explicit" & vbCrLf s = s & vbCrLf s = s & "'ラベルコントロールの配列" & vbCrLf s = s & "Private oLabels() As MSForms.Label" & vbCrLf s = s & vbCrLf s = s & "Private Function MyFractionalLabel(ByVal sText As String)" & vbCrLf s = s & " Dim sFormula() As String" & vbCrLf s = s & " Dim iFormat() As Long" & vbCrLf s = s & " Dim yMargin As Double" & vbCrLf s = s & " Dim xMargin As Double" & vbCrLf s = s & " Dim xBarMargin As Double" & vbCrLf s = s & " Dim dfLeft As Double" & vbCrLf s = s & " Dim dfTop As Double" & vbCrLf s = s & " Dim dfWidth As Double" & vbCrLf s = s & " Dim sChar As String" & vbCrLf s = s & " Dim sTmp As String" & vbCrLf s = s & " Dim iFlag As Long" & vbCrLf s = s & " Dim iCount As Long" & vbCrLf s = s & " Dim i As Long" & vbCrLf s = s & " Dim n As Long" & vbCrLf s = s & vbCrLf s = s & vbCrLf s = s & " '間隔の設定" & vbCrLf s = s & vbCrLf s = s & " '項目の間隔" & vbCrLf s = s & " xMargin = 3" & vbCrLf s = s & vbCrLf s = s & " '分数のバーと分子分母の垂直方向の間隔" & vbCrLf s = s & " yMargin = 1" & vbCrLf s = s & vbCrLf s = s & " '分子分母の幅に対する分数のバーの幅の増分" & vbCrLf s = s & " '（バーの両端にこの長さが追加されます。）" & vbCrLf s = s & " xBarMargin = 1" & vbCrLf s = s & vbCrLf s = s & vbCrLf s = s & " '文字列を;で区切り、配列を作成" & vbCrLf s = s & vbCrLf s = s & " If Right$(sText, 1) <> "";"" Then" & vbCrLf s = s & " sText = sText & "";""" & vbCrLf s = s & " End If" & vbCrLf s = s & vbCrLf s = s & " sTmp = """"" & vbCrLf s = s & " iCount = 0" & vbCrLf s = s & " iFlag = 0" & vbCrLf s = s & " i = 1" & vbCrLf s = s & " n = Len(sText)" & vbCrLf s = s & " Do While i <= n" & vbCrLf s = s & " sChar = Mid$(sText, i, 1)" & vbCrLf s = s & " Select Case sChar" & vbCrLf s = s & " Case ""\""" & vbCrLf s = s & " sTmp = sTmp & Mid$(sText, i + 1, 1)" & vbCrLf s = s & " i = i + 2" & vbCrLf s = s & " Case "";""" & vbCrLf s = s & " If iFlag = 0 Then" & vbCrLf s = s & " iFlag = 1" & vbCrLf s = s & " If Len(sTmp) > 0 Then" & vbCrLf s = s & " iCount = iCount + 1" & vbCrLf s = s & " ReDim Preserve sFormula(1 To iCount)" & vbCrLf s = s & " ReDim Preserve iFormat(1 To iCount)" & vbCrLf s = s & " sFormula(iCount) = sTmp" & vbCrLf s = s & " iFormat(iCount) = 0" & vbCrLf s = s & " End If" & vbCrLf s = s & " ElseIf iFlag = 1 Then" & vbCrLf s = s & " iFlag = 2" & vbCrLf s = s & " iCount = iCount + 1" & vbCrLf s = s & " ReDim Preserve sFormula(1 To iCount)" & vbCrLf s = s & " ReDim Preserve iFormat(1 To iCount)" & vbCrLf s = s & " sFormula(iCount) = sTmp" & vbCrLf s = s & " iFormat(iCount) = 1" & vbCrLf s = s & " Else" & vbCrLf s = s & " iFlag = 0" & vbCrLf s = s & " iCount = iCount + 2" & vbCrLf s = s & " ReDim Preserve sFormula(1 To iCount)" & vbCrLf s = s & " ReDim Preserve iFormat(1 To iCount)" & vbCrLf s = s & " sFormula(iCount - 1) = sTmp" & vbCrLf s = s & " iFormat(iCount - 1) = 2" & vbCrLf s = s & " sFormula(iCount) = """"" & vbCrLf s = s & " iFormat(iCount) = 3" & vbCrLf s = s & " End If" & vbCrLf s = s & " sTmp = """"" & vbCrLf s = s & " i = i + 1" & vbCrLf s = s & " Case Else" & vbCrLf s = s & " sTmp = sTmp & sChar" & vbCrLf s = s & " i = i + 1" & vbCrLf s = s & " End Select" & vbCrLf s = s & " Loop" & vbCrLf s = s & vbCrLf s = s & " 'ラベルを非表示にする" & vbCrLf s = s & " For i = 1 To UBound(oLabels)" & vbCrLf s = s & " oLabels(i).Visible = False" & vbCrLf s = s & " Next" & vbCrLf s = s & vbCrLf s = s & " 'ラベルが不足していたら追加する" & vbCrLf s = s & " If UBound(sFormula) > UBound(oLabels) Then" & vbCrLf s = s & " n = UBound(oLabels)" & vbCrLf s = s & " ReDim Preserve oLabels(0 To UBound(sFormula))" & vbCrLf s = s & " For i = n + 1 To UBound(sFormula)" & vbCrLf s = s & " Set oLabels(i) = Me.Controls.Add(""Forms.Label.1"", , False)" & vbCrLf s = s & " oLabels(i).TextAlign = fmTextAlignCenter" & vbCrLf s = s & " Next" & vbCrLf s = s & " End If" & vbCrLf s = s & vbCrLf s = s & " '基準位置の取得" & vbCrLf s = s & " dfLeft = oLabels(0).Left" & vbCrLf s = s & " dfTop = oLabels(0).Top + oLabels(0).Height / 2" & vbCrLf s = s & vbCrLf s = s & " '各ラベルに文字列を設定し大きさを自動調整する" & vbCrLf s = s & " dfWidth = oLabels(0).Parent.Width" & vbCrLf s = s & " For i = 1 To UBound(sFormula)" & vbCrLf s = s & " oLabels(i).BorderStyle = fmBorderStyleNone" & vbCrLf s = s & " oLabels(i).AutoSize = False" & vbCrLf s = s & " oLabels(i).Width = dfWidth" & vbCrLf s = s & " oLabels(i).Caption = sFormula(i)" & vbCrLf s = s & " oLabels(i).AutoSize = True" & vbCrLf s = s & " oLabels(i).AutoSize = False" & vbCrLf s = s & " Next" & vbCrLf s = s & vbCrLf s = s & " i = 1" & vbCrLf s = s & " Do While i <= UBound(sFormula)" & vbCrLf s = s & " Select Case iFormat(i)" & vbCrLf s = s & " Case 0" & vbCrLf s = s & vbCrLf s = s & " '通常表示の位置を設定" & vbCrLf s = s & " oLabels(i).Left = dfLeft" & vbCrLf s = s & " oLabels(i).Top = dfTop - oLabels(i).Height / 2" & vbCrLf s = s & vbCrLf s = s & " '次の項目の開始位置を設定" & vbCrLf s = s & " dfLeft = dfLeft + oLabels(i).Width + xMargin" & vbCrLf s = s & " i = i + 1" & vbCrLf s = s & " Case 1" & vbCrLf s = s & vbCrLf s = s & " '分母とバーのラベルがあるどうかチェック" & vbCrLf s = s & " If i + 2 > UBound(sFormula) Then" & vbCrLf s = s & " Exit Function" & vbCrLf s = s & " End If" & vbCrLf s = s & vbCrLf s = s & " '分子の位置を設定" & vbCrLf s = s & " oLabels(i).Left = dfLeft" & vbCrLf s = s & " oLabels(i).Top = dfTop - (oLabels(i).Height + yMargin)" & vbCrLf s = s & vbCrLf s = s & " '分母の位置を設定" & vbCrLf s = s & " i = i + 1" & vbCrLf s = s & " oLabels(i).Left = dfLeft" & vbCrLf s = s & " oLabels(i).Top = dfTop + yMargin" & vbCrLf s = s & vbCrLf s = s & " '分数のバーの表示と位置の設定" & vbCrLf s = s & " i = i + 1" & vbCrLf s = s & " oLabels(i).Caption = """"" & vbCrLf s = s & " oLabels(i).BorderStyle = fmBorderStyleSingle" & vbCrLf s = s & " oLabels(i).Left = dfLeft" & vbCrLf s = s & " oLabels(i).Height = 1" & vbCrLf s = s & " oLabels(i).Top = dfTop" & vbCrLf s = s & " If oLabels(i - 1).Width > oLabels(i - 2).Width Then" & vbCrLf s = s & " dfWidth = oLabels(i - 1).Width + xBarMargin * 2" & vbCrLf s = s & " Else" & vbCrLf s = s & " dfWidth = oLabels(i - 2).Width + xBarMargin * 2" & vbCrLf s = s & " End If" & vbCrLf s = s & vbCrLf s = s & " 'バー、分子、分母の幅を設定" & vbCrLf s = s & " oLabels(i).Width = dfWidth - 0.7" & vbCrLf s = s & " oLabels(i - 1).Width = dfWidth" & vbCrLf s = s & " oLabels(i - 2).Width = dfWidth" & vbCrLf s = s & vbCrLf s = s & " '次の項目の開始位置を設定" & vbCrLf s = s & " dfLeft = dfLeft + oLabels(i - 1).Width + xMargin" & vbCrLf s = s & " i = i + 1" & vbCrLf s = s & " End Select" & vbCrLf s = s & " Loop" & vbCrLf s = s & vbCrLf s = s & " 'ラベルを表示する" & vbCrLf s = s & " For i = 1 To UBound(sFormula)" & vbCrLf s = s & " oLabels(i).Visible = True" & vbCrLf s = s & " Next" & vbCrLf s = s & vbCrLf s = s & "End Function" & vbCrLf s = s & vbCrLf s = s & "Private Sub UserForm_Initialize()" & vbCrLf s = s & vbCrLf s = s & " 'ラベルの配列の先頭に基準位置のラベルを設定し、非表示にする。" & vbCrLf s = s & " ReDim oLabels(0 To 0)" & vbCrLf s = s & " Set oLabels(0) = Me.Label2" & vbCrLf s = s & " oLabels(0).Visible = False" & vbCrLf s = s & "End Sub" & vbCrLf s = s & vbCrLf s = s & "Private Sub CommandButton1_Click()" & vbCrLf s = s & " MyFractionalLabel TextBox1.Text" & vbCrLf s = s & "End Sub" & vbCrLf Set oVBComponent = ThisWorkbook.VBProject.VBComponents.Add(3) oVBComponent.Properties("Caption") = "ラベルで分数を表示するサンプル" With oVBComponent.Designer.Controls With .Add("Forms.Label.1", "Label1", True) .Left = 6 .Top = 3 .Width = 225 .Height = 15 .Caption = "通常;分子;分母;のパターンで入力してください。" End With With .Add("Forms.TextBox.1", "TextBox1", True) .Left = 6 .Top = 21 .Width = 153 .Height = 24 .Text = "1 +;3;100" End With With .Add("Forms.CommandButton.1", "CommandButton1", True) .Left = 162 .Top = 21 .Width = 72 .Height = 24 .Caption = "更新" End With With .Add("Forms.Label.1", "Label2", True) .Left = 6 .Top = 48 .Width = 225 .Height = 36 .Caption = "" End With End With With oVBComponent.CodeModule If .CountOfLines > 0 Then .DeleteLines 1, .CountOfLines End If .AddFromString s End With VBA.UserForms.Add(oVBComponent.Name).Show End Sub