2020-02-10

金額の桁数で、四捨五入する位を調節する

Excel

例えば現状の原価の9５％を、原価低減後の目標金額に設定したとする。
f:id:Infoment:20200210225626p:plain

60円などの端数が出て、キリが悪い。こんな時は、RoundDown関数で切り捨てるという方法がある。でも、どの桁で切り捨てたら良いだろう？

例えば一律、百の位で切り捨ててみる。すると、こうなる。
f:id:Infoment:20200210225933p:plain

何と、500円だったものがタダになってしまった。これは流石に、ＮＧだ。

そこで、このように考えた。

桁数を求める。
その桁数から二つ下の位を切り捨てる。

こんな感じだ。
f:id:Infoment:20200210230335p:plain

これなら桁数に関係なく、同じ式で対応できる。
後は、この金額でモノ作りが出来るよう、知恵を絞るだけです。

参考まで。

2020-02-09

導関数を求める

Excel VBA 試してみた正規表現

面白そうなテーマがあったので、挑戦してみた。

「y = 5x^3 + 2x^2 + 7x + 5」の導関数を求めよ

f:id:Infoment:20200209081223p:plain

導関数なので、微分した式を求める必要がある。
今回は、正規表現で解決してみた。

各項を以下のパターンで抽出してみる。

ａｘのｂ乗の後に「 + 」または「 - 」が続くもの

このとき厄介なのが、係数が１のとき、また１乗のとき。
例えばｘをわざわざ、

1×ｘの1乗

とは書かない。しかし省略された場合、何もないのでそのままでは「0」と判断してしまう。その辺りを加味して、このように作ってみた。

Sub Sample()
    ' 元の式。
    Dim Source As String
        Source = "y = 5x^3 + 2x^2 + 7x + 5"
    
    ' 正規表現（パターン検出用）
    ' Microsoft VBScript Regular Expression 5.5参照要
    Dim myReg As VBScript_RegExp_55.RegExp
    Set myReg = New VBScript_RegExp_55.RegExp
        
        ' 検出しても一回で止めない（全部拾う）。
        myReg.Global = True
        ' パターン定義。
        myReg.Pattern = "(\d*)x\^?(\d*)(\s[\+-]\s)"
    
    Dim i As Long
    ' マッチした数式の各項を格納するためのコレクション。
    Dim MC As VBScript_RegExp_55.MatchCollection
    ' 各項の中身を（）毎に分割する。
    Dim SM As VBScript_RegExp_55.SubMatches
    ' 微分した後の各項を格納するためのコレクション。
    Dim col As Collection
    Set col = New Collection
        ' パターンにマッチしたならば。
        If myReg.Test(Source) Then
            ' 各項をコレクションに格納。
            Set MC = myReg.Execute(Source)
            ' 各項について処理を行う。
            For i = 0 To MC.Count - 1
                ' 各項の値をさらに分割。
                Set SM = MC(i).SubMatches
                ' ax^bで値取得。
                Dim a As Long, b As Long
                    ' ax^b のaに相当する部分が空白なら、
                    ' それは1が省略されている。
                    If SM(0) = vbNullString Then
                        a = 1
                    Else
                        a = SM(0)
                    End If
                    
                    ' ax^bのbが無いならば、それは1が省略されている。
                    ' ax^bのbが1ならば、微分したあとの式で省略される。
                    If SM(1) = vbNullString Then
                        b = 1
                        col.Add a
                    ElseIf SM(1) = 2 Then
                        col.Add a * 2 & "x" & SM(2)
                    Else
                        b = SM(1)
                        col.Add a * b & "x^" & b - 1 & SM(2)
                    End If
            Next
        End If
        
    ' 答えの組立。
    Dim Answer As String
        For i = 1 To col.Count
            Answer = Answer & col.Item(i)
        Next
        
        MsgBox "dy/dx = " & Answer
End Sub

結果はこちら。
f:id:Infoment:20200209082227p:plain

一応答えは出たが、数式に他の文字が含まれた瞬間に、これは成立しなくなる。
あくまで限定的な場合に使用可ということで。

参考まで。

2020-02-06

コメントの挿入

Excel VBA 作ってみたユーザー定義関数

出張で、一週間近くブログを更新できなかった。
ということで、今日は軽めに。

セルのコメントを、マクロでこんな風に表示したい。
f:id:Infoment:20200206221312p:plain

ということで、関数にしてみた。とりあえず戻り値は、Rangeにしてみよう。

Function コメント(target_range As Range, ParamArray comments()) As Range
    Dim CommentCharacter As String
        CommentCharacter = Join(comments, vbNewLine)

    ' コメントを追加すると同時に、書式を変更する。
    With target_range.AddComment(CommentCharacter).Shape.TextFrame
        ' コメントのサイズを、文字に合わせて自動的に変更。
        .AutoSize = True

        ' 以下、フォントに関する変更。
        .Characters.Font.Name = "メイリオ"
        .Characters.Font.Size = 10
        .Characters.Font.Bold = False
    End With
    
    Set コメント = target_range
End Function

テスト結果がこちら。

Sub Test()
    コメント Range("D5"), "正義超人", "95万パワー"
End Sub

f:id:Infoment:20200206222619p:plain

リハビリ初日としては、こんなもんかな。

参考まで。

2020-01-30

Ａという文字を、Ａという文字パターンで認識してみる。

Excel VBA ユーザー定義関数

昨日は、Ａという文字をＡという文字で分割してみた。
infoment.hatenablog.com

今日はＡという文字を、Ａという文字パターンで認識してみる。
f:id:Infoment:20200130220411j:plain

↑ のように書くと、何だか良く判らない。しかし何のことはない、今度は正規表現で指定文字を数えてみようってだけの話だ。
ja.wikipedia.org

ということで、昨日の関数を書き換えてみた。

Function CountCharacter(source_char As String, count_char As String) As Long
    ' 正規表現。
    Dim myReg As Object
    Set myReg = CreateObject("VBScript.RegExp")
        ' 文字列全体を検索。
        myReg.Global = True
        ' 検索パターン。
        myReg.Pattern = count_char

    ' MatchCollection
    Dim mc As Object
        If myReg.TEST(source_char) Then
            Set mc = myReg.Execute(source_char)
            CountCharacter = mc.Count
        End If
End Function

昨日と同じ結果が得られた。
f:id:Infoment:20200130220918p:plain

これだけなら、わざわざ正規表現を使う必要は無い。昨日のSplit関数で、充分だ。この方式の特徴は、パターンを指定して数えることができるということ。例えば、こんな感じで。
f:id:Infoment:20200130221234p:plain

これはこれで、面白いかも。

参考まで。

2020-01-29

Ａという文字を、Ａという文字で分割してみる

Excel VBA ユーザー定義関数

面白いネタを拝見したので、昨日までのテーマを一時お休み。
f:id:Infoment:20200129232505j:plain

VBAには、Splitという関数がある。
docs.microsoft.com
文字通り、対象となる文字列を、指定文字で分割する関数だ。

では、Ａという文字をＡという文字で分割したらどうなるだろう。
試してみた。

Sub TEST()
    Dim arr As Variant
        arr = Split("A", "A")
End Sub

分割した戻り値は配列なので、arrという変数で受け取ってみた。
結果は以下の通り。
f:id:Infoment:20200129233032p:plain

Ａという文字を中心に、その左右に「無の空間」（ここでは""）だけが残ったような感じだ。概念的で、何とも面白い。

また、戻り値は０から始まる配列なので、UBound(arr)=1となる。奇しくも、「Ａ」が何個あるか？という問いがあれば、その答えと一致する。

ということで、「指定文字列内に指定文字が幾つあるか」を返す関数にしてみた。

Function CountCharacter(source_char As String, _
                        count_char As String) As Long
    CountCharacter = UBound(Split(source_char, count_char))
End Function

確認した結果が、↓こちら。
f:id:Infoment:20200129233756p:plain

特徴的なのは、数える文字が「ＡＢ」のような複数文字でもＯＫということ。この場合、「ＡＢ」というパターンが何セットあるかを数えることになる。
f:id:Infoment:20200129233943p:plain

「数える」以外のケースでも色々と応用が利くので、重宝しています。

参考まで。

2020-01-28

ユーザーフォームのサイズ変更　⑤ 操作用フォームを一つ追加

Excel VBA 試してみた

先日は、複数枚の画像をユーザーフォームに表示してみた。
infoment.hatenablog.com

今日は、先日の続き。
f:id:Infoment:20200128221546p:plain

まず先日の複数のユーザーフォームをNewして増やす手法は、私の独創ではない。書き忘れていたのだが、こちらを参照している。
thom.hateblo.jp

それで、先日の続きを作ろうとして昨晩、手が止まってしまった。これは何か扱い辛いぞ。１０個のユーザーフォームがあったら、一つずつ閉じて回るのか？面倒くさいことこの上ない。

ということで、全部壊して作り直してみた。
まず、ユーザーフォーム側の大部分のコードを、標準モジュールに移動させた。

Option Explicit
' 画像ファイル取得用。
Public FSO As Scripting.FileSystemObject
' ファイルパス格納用コレクション。
Public myFiles As Collection

' 画像ファイル保存場所。
Public Const SorceFolder As String = "C:\Temp"
Public cUF As ImageControlForm
Public UFs() As ImageViewForm

Sub ShowUFs()
    Set FSO = New Scripting.FileSystemObject
    Set myFiles = New Collection
    
    ' ファイルパス格納処理。
    Dim File As Scripting.File
        For Each File In FSO.GetFolder(SorceFolder).Files
            myFiles.Add File.Path
        Next
    
    ' コレクションのアイテムの数だけユーザーフォーム作成。
    ReDim UFs(1 To myFiles.Count)
    Dim i As Long
        For i = 1 To myFiles.Count
            Set UFs(i) = New ImageViewForm
                UFs(i).Show vbModeless
                ' イメージコントロールに画像ファイル設定。
                UFs(i).Image1.Picture = LoadPicture(myFiles(i))
        Next

    ' コントロール用ユーザーフォーム起動。
    Set cUF = New ImageControlForm
        cUF.Show vbModeless
        
        cUF.SpinButton1 = 3

End Sub

Public Property Get unit_width() As Long
' ユーザーフォームの単位幅。
' スピンボタンを押すたびに、この値の倍数で
' ユーザーフォームの幅を変化させる。
    unit_width = ActiveWindow.Width / 12
End Property

' 約数を求める関数。
' 約数を求めたい関数を１から順に割り、
' 余りが０の値を約数として辞書に格納する。
' ※MicroSoft Scripting Runtime 参照済み。
Public Function Devisor(source_number As Long) As Scripting.Dictionary
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    Dim i As Long
        For i = 1 To source_number
            If source_number Mod i = 0 Then
                Dict(Dict.Count + 1) = i
            End If
        Next
        Set Devisor = Dict
End Function

次いで、ユーザーフォームを二つ準備する。
１）写真表示用ユーザーフォーム
こちらは、何もコードを持たない、コントロールを配置しただけのフォーム。
f:id:Infoment:20200128222217p:plain

２）１）操作用のユーザーフォーム
f:id:Infoment:20200128222324p:plain

取り敢えず、サイズ変更用スピンボタンと、一括終了用ボタンを準備した。

Option Explicit

Private Sub CommandButton1_Click()
    Dim i As Long
        For i = 1 To UBound(UFs)
            Unload UFs(i)
        Next
End Sub

Private Sub UserForm_Initialize()
    ' スピンボタンの最大値と最小値を設定。
    SpinButton1.Min = 1
    SpinButton1.Max = 6
End Sub

Private Sub SpinButton1_Change()
    Static Dict As Scripting.Dictionary
        If Dict Is Nothing Then
            Set Dict = Devisor(12)
        End If

    ' ユーザーフォームのサイズ変更。
    ' 高さは、高さの約71％（１／√２倍）とした。
    ' ※馴染みのあるＡサイズ（A3やA4など）の比率。
    Dim i As Long
        For i = 1 To UBound(UFs)
            With UFs(i)
            ' ユーザーフォームのサイズ変更。
                .Width = unit_width * Dict(SpinButton1.Value)
                .Height = .Width / 2 ^ 0.5
                
            ' イメージのサイズ追従。
                .Image1.Width = .Width - 30
                .Image1.Height = .Height - 45
                .Image1.Top = 10
                .Image1.Left = 10
                
            ' ユーザーフォームの整列。
                .Top = 150
                .Left = (i - 1) * .Width
            End With
        Next
End Sub

それでは、試してみよう。
f:id:Infoment:20200128222805g:plain

一昨日より、幾分かマシになったか。
これでようやく、先に進めます。

参考まで。

2020-01-26

ユーザーフォームのサイズ変更　④ 画像の数だけユーザーフォームを作成

Excel VBA 試してみた

昨日は、ユーザーフォームに画像を表示させてみた。
infoment.hatenablog.com

今日は、複数枚の画像を、ユーザーフォームに表示してみる。
f:id:Infoment:20200126223651j:plain

毎回Canvaからダウンロードしている無償画像を、４つ準備した。
f:id:Infoment:20200126225116p:plain

今回の作戦は、こうだ。

指定フォルダ内のファイルパスを取得する。
ファイルパス毎にユーザーフォームを起動し、画像を表示する。

Sub Test()
    ' 画像ファイル取得用。
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    
    ' 画像ファイル保存場所。
    Const SorceFolder As String = "C:\Temp"
    
    ' ファイルパス格納用コレクション。
    Dim myFiles As Collection
    Set myFiles = New Collection
    
    ' ファイルパス格納処理。
    Dim File As Scripting.File
        For Each File In FSO.GetFolder(SorceFolder).Files
            myFiles.Add File.Path
        Next
    
    ' コレクションのアイテムの数だけユーザーフォーム作成。
    Dim UFs() As UserForm1
    ReDim UFs(1 To myFiles.Count)
    Dim i As Long
        For i = 1 To myFiles.Count
            Set UFs(i) = New UserForm1
                UFs(i).Show vbModeless
                ' イメージコントロールに画像ファイル設定。
                UFs(i).Image1.Picture = LoadPicture(myFiles(i))
                ' ユーザーフォームのサイズ指定。
                UFs(i).SpinButton1.Value = 2
        
                ' ユーザーフォームの整列。
                UFs(i).Top = 150
                UFs(i).Left = (i - 1) * UFs(i).Width
        Next
End Sub

複数表示に伴い、ユーザーフォーム側のコードも調整した。
調整箇所・・・Userform1 ⇒ Me に置き換える、など。
　　　　　　　これを行わないと、上手くサイズ変更できなかった。

Option Explicit

Private Property Get unit_width() As Long
' ユーザーフォームの単位幅。
' スピンボタンを押すたびに、この値の倍数で
' ユーザーフォームの幅を変化させる。
    unit_width = ActiveWindow.Width / 12
End Property

' 約数を求める関数。
' 約数を求めたい関数を１から順に割り、
' 余りが０の値を約数として辞書に格納する。
' ※MicroSoft Scripting Runtime 参照済み。
Private Function Devisor(source_number As Long) As Scripting.Dictionary
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    Dim i As Long
    Dim Counter As Long: Counter = 1
        For i = 1 To source_number
            If source_number Mod i = 0 Then
                Dict(Counter) = i
                Counter = Counter + 1
            End If
        Next
        Set Devisor = Dict
End Function

Private Sub SpinButton1_Change()
    Static Dict As Scripting.Dictionary
        If Dict Is Nothing Then
            Set Dict = Devisor(12)
        End If

    ' ユーザーフォームのサイズ変更。
    ' 高さは、高さの約71％（１／√２倍）とした。
    ' ※馴染みのあるＡサイズ（A3やA4など）の比率。
    Me.Width = unit_width * Dict(SpinButton1.Value)
    Me.Height = Me.Width / 2 ^ 0.5
    
    With Image1
        .Width = Me.Width - 30
        .Height = Me.Height - 72
        .Top = 40
        .Left = 10
    End With
End Sub

Private Sub UserForm_Initialize()
    ' スピンボタンの最大値と最小値を設定。
    SpinButton1.Min = 1
    SpinButton1.Max = 6
End Sub

試してみた結果がこちら。
f:id:Infoment:20200126231144g:plain

調整に思った以上に時間が掛かったため、今日はここまで。
明日に続きます。

参考まで。