部品づくり 図形がどのセルの上にあるか

imihitoさんに教えていただいた application.caller TopLeftCell BottonRightCell これらはとても便利そう。

注意すべきは，自分で作り自分だけが使うときは問題ないけど少しだけ図形がずれる，ということがあると想定外の不具合はありそうです。

Altキー押しながらセルの上にきっちり図形を置くと，TopLeftCellは想定通り動きますが，BottomRightCellは右下のセルを返します。

自分の想定ではTopLeftCellのほうを使えばいい，となりますが，ほんのちょこっとずらされてしまうだけでだめになるはず。

なので，図形の真ん中の座標で判定させてみるテストをしてみました。

Sub test()
Dim Sht As Worksheet: Set Sht = ActiveSheet
Dim Shp As Shape: Set Shp = Sht.Shapes(Application.Caller)

Dim CenterX As Long, CenterY As Long
CenterX = Shp.Left + Shp.Width / 2
CenterY = Shp.Top + Shp.Height / 2

Dim Rng As Range: Set Rng = Sht.Range(Shp.TopLeftCell.Address & ":" & Shp.BottomRightCell.Address)
Dim r As Range
For Each r In Rng
    If CenterX >= r.Left And CenterX < r.Left + r.Width And CenterY >= r.Top And CenterY < r.Top + r.Height Then
        MsgBox r.Address
        Exit For
    End If
Next

負荷を減らすべく，評価対象のセルの数を少なくできてたらいいな。

もしこれらで取得するセルを利用する場合は，セルを間違ったら大変なことになるはずなので，基本的には図形名等にセルアドレスを忍ばせて，それを利用することで想定外は無くすべきだと考えますが，次善の策としてはかなり有用だなぁと思います。

それにしてもCallerプロパティはいいですね。これは今後コード書くときに重宝する気がしています。

メモ

Excelで図形を作ってOnActionを使ってみようとしていたら，次の記事を見つけました。

Excel VBA を学ぶなら moug モーグ | 即効テクニック | OnActionで実行するプロシージャに引数を渡す

図形にマクロをつけて，引数もつけれると(;´▽｀A``

これはいい。

軽くテストしてみました。

Sub test()
    Dim Sht As Worksheet: Set Sht = ActiveSheet
    Dim Rng As Range: Set Rng = Sht.Range("c5:e8")

    Dim c As Range
    For Each c In Rng
        With Sht.Shapes.AddLabel(msoTextOrientationHorizontal, c.Left, c.Top, c.Width, c.Height)
            .Name = c.Address(False, False) & "_BTN"
            .OnAction = "'test2 """ & .Name & """ '"
            '.OnAction = "'test2 ""印刷""'"
        End With
    Next
    
End Sub


Sub test2(Str As String)
    MsgBox Str
End Sub

セルのシングルクリックイベントの代わりに図形をのせているので，各セルのleft,top,width,heightを使って図形を書き，それにOnActionをのっける。

セルのアドレスを捕まえることができるなら，いろいろとやれるのでそのためのものです。

testマクロを動かすと，

セルの上に図形をきれいにはりつけます。
無色透明にするなら　.Fill.Visible=msoFalse　をすればいいのかな。

これを実行すると，そのセルを選んだら(そこに貼り付けられている図形をクリックしたら)

このように，ちゃんとアドレスにしたがった値を返せます。

これはきっといいものな気がします。

onActionでマクロを貼り付けられた図形を動かすのはちょっと面倒なので，その点もいい感じ。

シートに貼る形のActiveXのリストボックスが，解像度が変わったり，タブレットで縦横表示が切り替わり続けると容易に表示が崩れたりと役立たずだったので，

リストボックス風なものを自分で実装したりしていました。
それを実現するためのいい手段が手に入った気がします。

追記　さらにメモ

d.hatena.ne.jp

のコメントのところから抜粋

参考にさせて頂き、助かりました。
第二引数の指定方法が分かりましたので、例示しておきます。
Sub AAAA(str1 As String, str2 As String)
.OnAction = "'AAAA ""引数１"", ""引数２""'"

きっといつか使う

さらにさらに追記

まぁこれも面白いわけですが，Powerpointの時もそうでしたが，セルに書く必要ないじゃないか　という根本的なところにいきますね。。
セルにこだわらずに，加えた図形群でリストボックスぽいものをやる方法を考えていこう。

トグル入力のコード Excel VBA

ブログ名前詐欺中です。　今取り組んでることのための部品。

キーボードを使わずタブレットだけで作業をする。

複雑なインターフェースは準備できない。　でも簡単な入力方法を実装したい。

いつも思いつくのは，お風呂に入ってるときや，帰宅，出勤時。

考えを変えるタイミングって大事ですね。

さて，とても単純なヤツデス。

Sub クリック入力(Add As String, Min As Long, Max As Long)
    Dim Rng As Range: Set Rng = ActiveSheet.Range(Add)
    Rng.Value = Rng.Value + 1
    If Rng.Value > Max Then Rng.Value = Min
End Sub

Sub Sht1_E5()
    Call クリック入力("e5", 0, 5)
End Sub

Sub Sht1_E6()
    Call クリック入力("e6", 0, 1)
End Sub

(´▽`) '`,、'`,、　ミジカイ

私は雑な人間ですが，さすがに，上のSSはわざとちょっとずれてるのをスルーしています。

E5,E6のセル上にボタンにするための透明な図形をのせて，それらに Sht1_E5 Sht1_E6をマクロ登録しています。

動画とらないで大丈夫ですよね。。あまりにも短いコードですから。。

クリックするたびに数値が１ずつ増え，最大値を超えると最小値になるよ，というコードです。

Excelのリスト入力は便利なんですけど，キーボードやマウスが使えない時ってあれってかなりちっちゃい。

その時のためのインターフェースとして考えてみました。明日実装してみよう。。

毎年この時期はデータ処理。。

教員をしていると，入試の時期が必ず来ます。

そろそろ，また今年の分の調整をし始めないといけません。

思えば，様々なアドバイスをいただき始めたのも，データ処理をどうするか，という話の頃から。

とてもありがたいことです。以前とはコードの書き方もけっこう変化しました。

そして，私はいつも同じ付近に考え方を戻して，いろんなことを気分でやるので，今回はある意味ふりだしに戻った感が否めません。

ですが，VBA組める同僚はほとんど出会わない職場ですので，他の人でも見てわかる，とか，自分が中身を忘れてもみればわかる・・・

そのようなものを求めるのもしょうがないのかなぁと思います。

infoment.hatenablog.com

Infomentさんのブログで配列のソートに取り組まれています。

PowerPointでものづくりをするときは否応なしにそっち方向でやっていかないといけないので，とても楽しみに様子を見させてもらってます。

わたしは，とりあえず今年は一時ワークシートを作ってそこで作業する，という方向に戻して考えようということにしました。

Stopでもそのあたりに入れておけば，ソートの途中経過など確認しやすいから，というのもありますね。

とりあえずてきとーに組んだのがこちら。Excel VBAです。

Function ソート(ソース As Variant, ParamArray Keys()) As Variant
    
    Dim Data As Variant, 行数 As Long, 列数 As Long
    If TypeName(ソース) = "Range" Then
        行数 = ソース.Rows.Count
        列数 = ソース.Columns.Count
        Data = ソース.Value
    Else
        行数 = UBound(ソース, 1)
        列数 = UBound(ソース, 2)
        Data = ソース
    End If
    
    Dim TempSht As Worksheet
    Set TempSht = ThisWorkbook.Worksheets.Add
    
    Dim s As Worksheet, No As Long, flg As Boolean
    Do
        No = No + 1
        flg = False
        For Each s In ThisWorkbook.Worksheets
            If s.Name = "作業用一時シート" & Format(No, "00") Then flg = True
        Next
    Loop Until flg = False
    TempSht.Name = "作業用一時シート" & Format(No, "00")

    Dim SObj As Sort, TempRng As Range, i As Long, j As Long
    Set TempRng = TempSht.Range(TempSht.Cells(1, 1), TempSht.Cells(行数, 列数))
    TempRng.Value = Data

    Set SObj = TempSht.Sort
    With SObj
        .SortFields.Clear
        .SetRange TempRng
        .Header = xlYes
        For i = 0 To UBound(Keys) - 1 Step 2
            .SortFields.Add Key:=TempRng.Cells(1, Keys(i)), Order:=Switch(Keys(i + 1) = True, xlAscending, Keys(i + 1) = False, xlDescending)
        Next
        .Apply
    End With
    
    ソート = TempRng.Value
    
    Application.DisplayAlerts = False
        TempSht.Delete
    Application.DisplayAlerts = True
    
    
End Function

Function 抽出(ソース As Variant, flg As Variant, ParamArray Keys()) As Variant
    Dim i As Long, j As Long, k As Long, l As Long, Flg2 As Boolean
    Dim 行数 As Long, 列数 As Long, tmp() As Variant
    
    行数 = UBound(ソース, 1)
    列数 = UBound(ソース, 2)
    
    If flg = True Then
        ReDim tmp(1 To 行数, 1 To UBound(Keys) + 1)
        For i = 1 To UBound(ソース, 1)
            k = 1
            For l = 0 To UBound(Keys)
                tmp(i, k) = ソース(i, Keys(l))
                k = k + 1
            Next l
        Next i
    Else
        ReDim tmp(1 To 行数, 1 To 列数 - UBound(Keys) - 1)
        k = 1
        For j = 1 To UBound(ソース, 2)
            Flg2 = True
            For l = 0 To UBound(Keys)
                If j = Keys(l) Then Flg2 = False
            Next
            If Flg2 = True Then
                For i = 1 To UBound(ソース, 1)
                    tmp(i, k) = ソース(i, j)
                Next
                k = k + 1
            End If
        Next
    End If
    
    抽出 = tmp
End Function

Sub テスト()
    Dim ret As Variant
    ret = 抽出(ソート(Sheet1.Range("a1").CurrentRegion, 8, True, 5, True), True, 5, 6, 7, 9)
    
    Sheet4.Cells(1, 1).Resize(UBound(ret, 1), UBound(ret, 2)).Value = ret
    Stop
End Sub

Sub テスト2()
    Dim a As Variant: a = Sheet1.Range("a1").CurrentRegion.Value
    Dim b As Variant: b = 抽出(a, False, 2, 3)
    Stop
End Sub

自分用メモが主のブログでもありますので，説明とかいろいろと省きまくりなのはスルーしてほしいところです。

一時シートをつくり，そこにデータを放り込んでソートオブジェクトにおまかせ，というやつです。

あと，ソートの結果の一部を利用したり，または，ほとんど利用するんだけど，数列分は消したいという作業をよくやるので，抽出する関数も用意しています。

Sheet1のデータを取り込んで，一部抽出したり，ソート結果をさらに抽出する，という作業を　テスト や　テスト2
とかでやってみてますが，見た目にはまともに動いてそうでした。。

結局，速いアルゴリズムが優れたソートを自分はあまり実装できず，できてバブルソートだったりするので，

ExcelならSortオブジェクト使い倒してしまえ，という気分で作ったものです。

いくつキー与えてもやってくれるし，このマクロ組んでたら，Sortにcustomorderが使えるというのに今更ながらに知って驚いたり，

やっぱりいろいろと気楽にやってみるもんだなぁと思ったところです。。

－－
わたしがいる学校ではそろそろ文化祭。

同僚に突然仕事を振られて，準備期間ほんのちょっとなのに　販売で使うシステムを組まされたりしています。

かなり以前に，小さなテキストメモみたいなものを吐き出して共通に見れるフォルダに放り込み，それをデータとして使う，，というシステムを作ったことがありました。

きちんとルール作りをすれば，データはその1KB程度のテキストがたくさん存在するだけであり，Excelが固まってもデータはほとんど消えることなく，

システムも小さくて済む。とても気楽に多人数でデータを扱えるシステムができている気がしています。

まさかこんなところで日の目を見るとは思わないものづくりでしたが，いつどんなものが役に立つかわからないものだなぁと思う。

思いつきは役に立とうが立つまいが一度は形にして，蓄積していけばいつか時間がないときにささっと対応できるなぁ，と２年ほど前の自分をほめつつ，

極めて短い準備期間なので，不具合をとても不安にも思いつつ作業しているところです。。

ひと段落しています。(VBAコード一切ありません)

とりあえず，作った教材を紹介する，という機会が終わりました。

仕事で人にものを説明することを日々やっている割に，やはり緊張するものですね。

また，PowerPoint2016のノートPCとPowerPoint2013のタブレットで動作確認をし，さらに直前に，

説明する電子黒板と同じ状態であろう，隣の部屋の電子黒板で動くことを確認していたのに，

実際説明するとき(PowerPoint2013でした)，途中でマクロが止まってΣ(･ω･ﾉ)ﾉ！びっくりしました。

こういうとこは，さすが自分だな・・(;´▽｀A``と思う次第。。

疑問なのは，普段スライドショーの完遂が優先され，コードエラーを直接吐かず沈黙するPowerPointが

エラーを吐いて止まったこと。。

どういう状態だったのか興味があります。確かめようはありませんが。。

いい経験ですね。やはり，動かす機械で確認をとっておかないといけないです。

一部，思い通りにいかなかったとはいえ，その部分はどちらかといえば枝葉の部分で主幹部分ではなかったので，

軽くスルーしてしまいました。

自分の適当さをそこでも感じたところです。

・・・

終わったし，何かまた何か作ってみよう。何に手を出そうか。。

( ´ー｀)ﾌｩｰ．．．

有効数字 今度こそ大丈夫??

まだ変なとこありましたので，書き直してみた。

うーん。なんと面倒な。。気にせずやれればいいんですが(;´▽｀A``　固定小数点でやれない数値の扱いって面倒ですね。

できるだけシンプルな方法を今後も考えます。主目的がここじゃないせいで，トライアンドエラーでしかやってない(;´▽｀A``

Function 有効数字表示(値 As Variant, 桁 As Long, 指数表示 As Boolean) As String
    Dim Val_ As String, Format_ As String
    If 桁 = 1 Then Format_ = "0e-0" Else Format_ = "0." & String(桁 - 1, "0") & "e-0"
    Val_ = Format(CSng(値), Format_)
    
    If 指数表示 = True Then
        有効数字表示 = Replace(Val_, "e", "×10^")
    Else
        Dim 数値部分, 桁部分, tmp, tmp2, tmp3, tmp4
        数値部分 = Left(Val_, InStr(Val_, "e") - 1)
        桁部分 = Mid(Val_, InStr(Val_, "e") + 1)
        有効数字表示 = CSng(数値部分 & "e" & 桁部分)
        If 桁 = 1 Then Exit Function
        
        If InStr(有効数字表示, "E") = 0 Then
            If InStr(有効数字表示, ".") > 0 Then tmp = Len(有効数字表示) - 1 Else tmp = Len(有効数字表示)
            tmp = Format(CSng(数値部分) / CSng(有効数字表示), "0e-0")
            tmp2 = Replace(数値部分, ".", "")
            tmp3 = Mid(tmp, InStr(tmp, "e") + 1)
            Select Case tmp3
                Case Is = 0
                    有効数字表示 = 数値部分
                Case Is > 0
                    If tmp = 1 Then
                        有効数字表示 = "0." & tmp2
                    Else
                        有効数字表示 = "0." & String(tmp3 - 1, "0") & tmp2
                    End If
                Case Is < 0
                    tmp4 = Len(有効数字表示)
                    If tmp4 < 桁 Then
                        有効数字表示 = 有効数字表示 & "." & String(桁 - tmp4, "0")
                    End If
            End Select
            
        End If
        
    End If
End Function

ちまちま確かめていると，間違いに気づかないのでExcelにこのFunctionを放り込んでチェック

大丈夫そうだけどなぁ(;´▽｀A``

有効数字 修正をはじめてます。

有効数字を処理する部分がまずそうだったので修正中です。

Function 有効数字表示(値 As Variant, 桁 As Long, 指数表示 As Boolean) As String
    Dim Val_ As String, Format_ As String
    If 桁 = 1 Then Format_ = "0" Else Format_ = "0." & String(桁 - 1, "0") & "e-0"
    Val_ = Format(CSng(値), Format_)
    
    If 指数表示 = True Then
        有効数字表示 = Replace(Val_, "e", "×10^")
    Else
        有効数字表示 = CSng(Left(Val_, InStr(Val_, "e") - 1) & "e" & Mid(Val_, InStr(Val_, "e") + 1))
        
        If InStr(有効数字表示, "E") = 0 Then
            Dim 数値スタート As Long, i As Long, 数値桁 As Long
            For i = 1 To Len(有効数字表示)
                If Mid(有効数字表示, i, 1) <> "0" And Mid(有効数字表示, i, 1) <> "." Then
                    数値スタート = i
                    Exit For
                End If
            Next
            
            数値桁 = Len(有効数字表示) - 数値スタート + 1
            If 桁 > 数値桁 Then
                If Len(有効数字表示) = 1 Then 有効数字表示 = 有効数字表示 & "."
                有効数字表示 = 有効数字表示 & String(桁 - 数値桁, "0")
            End If
        End If
    End If
End Function

数値桁 = Len(有効数字表示) - 数値スタート + 1
If 桁 > 数値桁 Then
If Len(有効数字表示) = 1 Then 有効数字表示 = 有効数字表示 & "."
有効数字表示 = 有効数字表示 & String(桁 - 数値桁, "0")
End If

最後当たりのこの辺がうまくいっていません。
考え中。

追記

とりあえず，トライアンドエラーでいじってみました。

フローチャートを書いて根元から考えようとしないヤツですみません(;´▽｀A``

Function 有効数字表示(値 As Variant, 桁 As Long, 指数表示 As Boolean) As String
    Dim Val_ As String, Format_ As String
    If 桁 = 1 Then Format_ = "0e-0" Else Format_ = "0." & String(桁 - 1, "0") & "e-0"
    Val_ = Format(CSng(値), Format_)
    
    If 指数表示 = True Then
        有効数字表示 = Replace(Val_, "e", "×10^")
    Else
        Dim 数値部分, 桁部分, tmp, tmp2
        数値部分 = Left(Val_, InStr(Val_, "e") - 1)
        桁部分 = Mid(Val_, InStr(Val_, "e") + 1)
        有効数字表示 = CSng(数値部分 & "e" & 桁部分)
        If 桁 = 1 Then Exit Function
        
        If InStr(有効数字表示, "E") = 0 Then
            If InStr(有効数字表示, ".") > 0 Then tmp = Len(有効数字表示) - 1 Else tmp = Len(有効数字表示)
            tmp = Format(CSng(数値部分) / CSng(有効数字表示), "0e-0")
            tmp = Mid(tmp, InStr(tmp, "e") + 1)
            tmp2 = Replace(数値部分, ".", "")
            Select Case tmp
                Case Is = 0
                    有効数字表示 = 数値部分
                Case Is > 0
                    If tmp = 1 Then
                        有効数字表示 = "0." & tmp2
                    Else
                        有効数字表示 = "0." & String(tmp - 1, "0") & tmp2
                    End If
                Case Is < 0
                    有効数字表示 = Left(tmp2, 1 - CLng(tmp)) & "." & Mid(tmp2, 2 - CLng(tmp))
                    If Right(有効数字表示, 1) = "." Then 有効数字表示 = Left(有効数字表示, Len(有効数字表示) - 1)
            End Select
            
        End If
        
    End If
End Function

イミディエイトウィンドウでいろいろやってみた感じはいけそうなんだけど・・，さすがに何度も間違ったのでまだ疑っています(;´▽｀A``

あとあきらかに美しくないので，きちんと統合していこうと思います。