ほっとひといき給湯室

ほっとひといき給湯室の掲示板です。お気軽にどうぞ!
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
VBAつれづれ草
投稿日時: 17/06/05 22:26:42
投稿者: simple

まったく雑談と言うわけでもなく、VBAなどをテーマに、自由に意見交換をしてみたいと思います。
 
では、言い出しっぺの私から。
 
MicrosoftのForumの質問から。
 
「Excel2011VBA  Evaluate等の、速度について」
https://social.msdn.microsoft.com/Forums/ja-JP/93c70c22-454e-4ba3-b3d0-b0eb3d20a60b/excel2011vba12288?forum=vbajp
 
3000×3000の整数データの最小値を求めるということで、
(1)ワークシート関数の使用
(2)Evaluateの利用
(3)配列データの逐次大小比較
(4)ワークシートの逐次大小比較
の4つの方法の速度を比較したらしい。
 
この質問者さんによると、繰り返し計算をさせた結果、
 

                            指数                    実時間(秒)
(1)Worksheet.Minメソッド   (100)        /     376.703125
(2)Evaluateメソッド     0000.002074  /       0.007813
(3)Loop Range        0015.577170  /      58.679688
(4)Loop Variant       2828.864739  /  10,656.421875
であるという。
 
そんなばかな、と言うのが第一印象。(2)がそんなに速い訳がない。
 
で、少しコードを調べてみると、
Evaluateで何をしているかというと、RandBetweenを一度実行しているだけ。
比較の対象が全然違うやん。そりゃ速いに決まっている。
 
それとワークシート関数を使うときに、
Application.WorksheetFunction.Min(lp.Rg.Value)
としているが、これは
Application.WorksheetFunction.Min(lp.Rg)
とRangeオブジェクトそのものを対象にすべきで、
配列を対象にするとそれだけ遅くなる。
 
私がざっと計算させたところ、
(2)は(1)の 2 倍程度
(3)は 3.5倍程度
(4)は 600 倍程度
で(1)が最速という結果になった。
どうでしょう、皆さんの感覚に合うでしょうか。
(またテスト手法の妥当性などについてもご指摘あれば)

回答
投稿日時: 17/06/08 07:23:52
投稿者: sy

simple さんの引用:

3000×3000の整数データの最小値を求めるということで、
(1)ワークシート関数の使用
(2)Evaluateの利用
(3)配列データの逐次大小比較
(4)ワークシートの逐次大小比較
の4つの方法の速度を比較したらしい。
 
私がざっと計算させたところ、
(2)は(1)の 2 倍程度
(3)は 3.5倍程度
(4)は 600 倍程度
で(1)が最速という結果になった。
どうでしょう、皆さんの感覚に合うでしょうか。
(またテスト手法の妥当性などについてもご指摘あれば)

 
テストコードに問題があるのでは?
私の環境で以下のコードを実行してみました。
Sub test0()
    Dim v(1 To 3000, 1 To 3000) As Long
    Dim i As Long, k As Long

    For i = 1 To 3000
        For k = 1 To 3000
            v(i, k) = Int(Rnd * 100000) + 1
        Next k
    Next i
    Range("A1").Resize(3000, 3000).Value = v

End Sub

Sub test1()
    Dim t As Double
    Dim d As Long

    t = Timer
    d = WorksheetFunction.Min(Range("A1:DJK3000"))
    Debug.Print "test1", d, Timer - t

End Sub

Sub test2()
    Dim t As Double
    Dim d As Long

    t = Timer
    d = Evaluate("Min(A1:DKJ3000)")
    Debug.Print "test2", d, Timer - t

End Sub

Sub test3()
    Dim t As Double
    Dim r As Range
    Dim d As Long

    t = Timer
    d = Range("A1").Value
    For Each r In Range("A1").CurrentRegion
        If d > r Then d = r
    Next r
    Debug.Print "test3", d, Timer - t

End Sub

Sub test4()
    Dim t As Double
    Dim v1 As Variant
    Dim v2 As Variant
    Dim d As Long

    t = Timer
    v1 = Range("A1").CurrentRegion.Value
    d = v1(1, 1)
    For Each v2 In v1
        If d > v2 Then d = v2
    Next v2
    Debug.Print "test4", d, Timer - t

End Sub

結果は、以下のようになりましたよ。
最小値の検索結果は見にくかったので省きました。
test1 0.13671875
test1 0.125
test1 0.12890625
test1 0.12109375
test1 0.119140625
 
test2 0.09765625
test2 0.12109375
test2 0.09765625
test2 0.123046875
test2 0.1328125
 
test3 20.1875
test3 20.00390625
test3 20.013671875
test3 20.16015625
test3 20.244140625
 
test4 4.01171875
test4 4.01171875
test4 4.015625
test4 4.013671875
test4 4.03125

投稿日時: 17/06/08 22:57:44
投稿者: simple

syさん どうもありがとうございました。
syさんのコードを私の非力マシンで動かしましたら以下のようになりました。
(Win7 Excel2010)
 
文字列のEvaluateがワークシート関数に比して少し時間がかかるのは、
当方のマシンの低能力のせいかもしれません。
 

                        平均         指数
test1       0.0625      0.0625       1.0
test1       0.0625                  
test1       0.0625                  
test1       0.0625                  
test1       0.0625                  
test1       0.0625                  
                                    
test2       0.140625    0.135416667   2.2
test2       0.125                   
test2       0.125                   
test2       0.15625                 
test2       0.140625                
test2       0.125                   
                                    
test3       26.7734375  27.22526042 435.6
test3       26.671875               
test3       27.890625               
test3       28.203125               
test3       27.1328125              
test3       26.6796875              
                                    
test4       2.1953125   2.234375     35.8
test4       2.21875                 
test4       2.296875                
test4       2.3203125               
test4       2.1796875               
test4       2.1953125      

 
なお、私のコードによる配列処理が、比較的短時間で済んでいるのは、
配列そのものを作成済みのところから出発しているので、
syさんの
v1 = Range("A1").CurrentRegion.Value
に相当する部分をショートカットできているからだと思いました。
 
また、ワークシートにその都度アクセスする逐次処理が遅いのは、
20回ほど処理を繰り返しているので、差が開いているのかもしれません。
まあ、遅いことはわかりきっていて普通は採らない手法なので、
正確に比較しても意味が乏しい気がします。
 
いずれにしても、ありがとうございました。

回答
投稿日時: 17/06/09 10:36:38
投稿者: hatena
投稿者のウェブサイトに移動

simple さんの引用:
この質問者さんによると、繰り返し計算をさせた結果、
 
                            指数                    実時間(秒)
(1)Worksheet.Minメソッド   (100)        /     376.703125
(2)Evaluateメソッド     0000.002074  /       0.007813
(3)Loop Range        0015.577170  /      58.679688
(4)Loop Variant       2828.864739  /  10,656.421875
であるという。
 
そんなばかな、と言うのが第一印象。(2)がそんなに速い訳がない。

私もその質問はみてました。そして、そんなばかな、とおなじ同じ印象を持ちましたが、質問文もコードを読みづらくてとても検証する気にならなくてスルーしてました(;・∀・)
 
syさんの検証コードを自分の環境で実行してみました。
 
test1	0.03515625	0.03671875	1.0 
test1	0.0390625		
test1	0.03515625		
test1	0.03515625		
test1	0.0390625		
			
test2	0.0703125	0.07109375	1.9 
test2	0.0703125		
test2	0.0703125		
test2	0.07421875		
test2	0.0703125		
			
test3	10.6015625	10.55546875	287.5 
test3	10.52734375		
test3	10.52734375		
test3	10.58203125		
test3	10.5390625		
			
test4	1.52734375	1.5703125	42.8 
test4	1.53515625		
test4	1.59375		
test4	1.62890625		
test4	1.56640625		

 

回答
投稿日時: 17/06/09 21:45:04
投稿者: sy

ちょっとtest1で間違い発見!

    d = WorksheetFunction.Min(Range("A1:DJK3000"))
DJKじゃなくてDKJでした><
検証までして頂いたお二方すいません。。。
でも0.01も変わらないとは思います。
 
お二方の結果を見て、私のPCは遅いなぁと言うのは分かっていた事なのですが、今度のボーナスでPC買おうか本気で悩む所です。
 
test3・4は乱数の生成具合で、IF文のTRUEの実行回数にも大きく左右されるので、3と4の比較でみればどれも妥当な結果と思いましたが、
test1・2は、なぜか私のPCだけ全然違う結果になってますね。
非力すぎて描画が追い付いてないのかな???
 
今までEvaluateもそんなに言うほど遅くないと思ってたけど、私のPCだからだったんですねw
お二方とも此方こそ検証ありがとうございました。
 

回答
投稿日時: 17/06/13 16:23:42
投稿者: hatena
投稿者のウェブサイトに移動

VBAをテーマとするスレッドということなので、ひとつ話題提供を。
 
『子供の計算問題』(寧々のパパ) エクセル Excel [エクセルの学校]
http://www.excel.studio-kazu.jp/kw/20170610161728.html
 
の質問ですか、なかなかおもしそうな題材なので、注目していたのですが、
最初の質問の仕様が曖昧で、かつ後出しで情報が追加されて、混沌とした状況になっていますね。
 
下記のような命題に落とし込んだら、アルゴリズム問題の題材として面白そうです。
 
任意の整数値を6個選択する。
このうち、5個と4演算子(+ - * /)をすべて使って数式を生成して、
計算結果が残りの1個の整数値となる式をすべて出力せよ。
()は自由につかってよいものとする。
 
問題例
5個の整数値 1, 2, 8, 6, 22
計算結果 14
 
正解例
 
1 + (8 * 6 - 22) / 2 = 14
 

Sub test()
    Dim AryNum
    Dim Ans As Long
    Dim i As Long

    AryNum = Array(1, 2, 8, 6, 22)
    Ans = 14
    i = 1


    '正解式の結果はワークシートの A1 から下に順次出力
    Cells(i,1).Value = "1 + (8 * 6 - 22) / 2"


End Sub

 
私の概算では、上記の条件でのすべての数式の組み合わせは、最大126000通り。
これならなんとかなりそうです。
 
 
ちなみに、()は使わない場合は、5*4*4*3*3*2*2*1*1 の 2880 通りで上記のスレッド内でコードが提示されてます。
ためしてみましたが一瞬で結果がでました。
 
これに()の使用を許可するとなると、なかなか複雑なロジックが必要になりそうですね。
 
VBAエキスパートの皆さん、チャレンジしてみませんか。
 
私自身はアイデアはあるのですが、今日は夜9時まで仕事なのでそれらか取り組んでみようかと。

投稿日時: 17/06/14 21:38:12
投稿者: simple

sy さんコメントありがとうございました。
 
そして、hatenaさん面白そうなテーマのスレッドの紹介ありがとうございました。
 
そうですねえ、私も質問者さんの
>5つの数字 13・2・3・5・6 を+−×÷を使い答えを1にします。
という文章からは、どうみてもカッコは使わないと読めましたね。
 
その前提なら、私なら例えばこんな風に書きますかね。(ネスト深いので 2タブにしています)
内容的には???さんのと全く同じですけど。
 

Dim num(1 To 5) As Long
Dim op(1 To 4) As String
Dim k As Long

Sub test()
  Dim k1&, k2&, k3&, k4&, k5
  Dim t
  t = Timer
  op(1) = "+": op(2) = "-": op(3) = "*": op(4) = "/"
  num(1) = 13: num(2) = 2: num(3) = 3: num(4) = 5: num(5) = 6
  k = 0
  For k1 = 1 To 5
    For k2 = 1 To 5
      If k2 <> k1 Then
        For k3 = 1 To 5
          If k3 <> k1 Then
            If k3 <> k2 Then
              For k4 = 1 To 5
                If k4 <> k1 Then
                  If k4 <> k2 Then
                    If k4 <> k3 Then
                      For k5 = 1 To 5
                        If k5 <> k1 Then
                          If k5 <> k2 Then
                            If k5 <> k3 Then
                              If k5 <> k4 Then
                                Call check(k1, k2, k3, k4, k5)
                              End If
                            End If
                          End If
                        End If
                      Next
                    End If
                  End If
                End If
              Next
            End If
          End If
        Next
      End If
    Next
  Next
  Debug.Print "すべてで " & k & " 通り"
End Sub

Function check(k1, k2, k3, k4, k5)
  Dim j1&, j2&, j3&, j4&
  Dim s As String
  
  For j1 = 1 To 4
    For j2 = 1 To 4
      For j3 = 1 To 4
        For j4 = 1 To 4
          s = num(k1) & op(j1) & num(k2) & op(j2) & num(k3) & op(j3) & num(k4) & op(j4) & num(k5)
          If Application.Round(Evaluate(s), 6) = 1 Then
            'Debug.Print s
            k = k + 1
            Cells(k, 5).Value = s
          End If
        Next
      Next
    Next
  Next
End Function

全部で138とおりになったが、順序の違いだけのものは同一視すると
13/2-3/6-5
13-2-5/3*6
13-2*5-6/3
5*6-13*2-3
2/6-13/3+5
13+3-5/2*6
13-3*5+6/2
3/2*6-13+5
2*6-13-3+5
13+2-3-5-6
の 10種類になりますね。
 
ちなみに、???さんのコードは、
j3を i3とタイプミスしていて38種類となっていますが、
演算子を一つずつ使う場合は、40種類になります。
 
それにしても、あちらの質問者さん、
質問は一貫していないし、
回答者の仕様確認に答えるでもなく、とてもつきあいきれないですな。
マイペースな方ですね。
単に娘にいい顔したいだけのパパなんでしょうか。
まあ、テーマの提供という点だけは評価しますが。

投稿日時: 17/06/14 22:12:15
投稿者: simple

カッコを任意に使用する場合は、ちょっと難しそうですね。
 
VBAから逸れますので、お急ぎの方は以下は読まずにスキップして下さい。
 
こうしたゲームは CountDown puzzle と呼ばれているものに近いようです。
 
この種の問題は、例えばHaskellなどの関数型プログラムを使うと
うまく記述できるようです。
 
Graham Huttonの Programming in Haskellの第11章とか、
Richard Bird の PEARLS OF FUNCTIONAL ALGORITHM DESIGN の第20章
などが参考になります。(後者はネット上にPDFがありますね)
 
Haskellには代数データ型という強力な概念があり、
data Expr = Num Int | App Op Expr Expr
data Op = Add | Sub | Mul | Div
のようにして、
当該の式を表現するデータ型Exprを
(式は、自然数であるか、式と式に演算子を作用させたもの、といった)
再帰的な方式で定義することができ、
これを使って数値と演算子の自由な組み合わせを表現できます。
 
解法の考え方は基本的には同じで、
与えられた数字のリストから、
すべての式の組み合わせを再帰的に作成し、
全探索するというものです。
後者の本には、そうした力ずくの方法を紹介したあと、
コードの最適化手法が段階を追って説明されています。
 
VBAは表現力が相対的に乏しいので、その点ハンディがあるかもしれませんが、
エキスパートの皆さんのトライを楽しみにしています。

投稿日時: 17/06/14 22:33:36
投稿者: simple

Function checkの引数の型宣言を忘れています。むろん、 As Longです。
とても代数的データ型を云々している場合ではないかもwww

回答
投稿日時: 17/06/14 23:38:29
投稿者: かすみの

(重複は考慮せず)任意の括弧で考慮すると
逆ポーランドで書けば良い…のかな?
 
nは任意の数値(1行内のnはすべて異なるものとする)
?は任意の演算子(1行内の?はすべて異なるものとする)
スペースは区切り文字とする。
 
とこんな感じ?(9パターン)

n n n n n ? ? ? ? 
n n n n ? ? ? n ? 
n n n ? ? n n ? ? 
n n n ? ? n ? n ? 
n n ? n n n ? ? ?
n n ? n n ? n ? ?
n n ? n n ? ? n ?
n n ? n ? n n ? ?
n n ? n ? n ? n ?

それで数値の入り方は5!
演算子の入り方は4!
1行あたり5!*4!
9パターンなので、5!*4!*9=25920通り
 
それぞれの文字列を生成して、
逆ポーランドの計算部品を用意して結果と比較して…
最終的に括弧ありの式に整形して出力すればいける…かしら?
 
と思いつきだけ書いて実装はしないのですが…。
 

回答
投稿日時: 17/06/15 16:10:20
投稿者: hatena
投稿者のウェブサイトに移動

投稿した日はレスがつかなかったのでちょっとテンション下がっていたました。
昨日は仕事の疲れで掲示板をチェックせずに寝てしましったので、今朝、
起きてみたらレスがたくさんついていて、びっくり。
 
simpleさん
> >5つの数字 13・2・3・5・6 を+−×÷を使い答えを1にします。
> という文章からは、どうみてもカッコは使わないと読めましたね。
>
> その前提なら、私なら例えばこんな風に書きますかね。(ネスト深いので 2タブにしています)
 
再帰を使うとシンプルにできそうです。
10数年前にブックオフで購入した「VBによるはじてめのアルゴリズム入門」に「順列の生成」というコードがありましたので、それを参考に途中までつくってみました。
 

Const Nums = "13 2 3 5 6"
Const Opes = "+ - * /"

Dim P
Dim N As Long
Dim k As Long

Sub perm_test()
    Dim i As Long
    k = 0
    P = Split(" " & Opes)
    N = UBound(P)
    perm 1
    
    P = Split(" " & Nums)
    N = UBound(P)
    perm 1    
End Sub

Private Sub perm(i As Long)
    Dim j As Long, t As String
    If i < N Then
        For j = i To N
            t = P(i): P(i) = P(j): P(j) = t
            perm i + 1
            t = P(i): P(i) = P(j): P(j) = t
        Next j
    Else
        For j = 1 To N
            Debug.Print P(j);
        Next j
        Debug.Print
    End If
End Sub

 
これで、演算子の順列24、数値の順列120 をイミディエイトウィンドウに出力します。
これを演算子、数値の配列にいれて、すべての組み合わせで式を生成して、Evaluateすればできそうです。
 
simpleさん
> 単に娘にいい顔したいだけのパパなんでしょうか。
 
この気持はよく分かります。父親は娘に前ではちょっとカッコつけたいものです。自分の娘はもう成人してますが、小さい頃に似たようなことがあったのを思い出して懐かしだりしてました。
質問者としては、?ですが。

回答
投稿日時: 17/06/15 17:05:33
投稿者: hatena
投稿者のウェブサイトに移動

かすみのさん
> (重複は考慮せず)任意の括弧で考慮すると
> 逆ポーランドで書けば良い…のかな?
 
逆ポーランド記法は私もすぐ思いつきました。
()を使用しなくても計算順序を任意に指定できるし、式の長さも9桁に固定できますしね。
 
最初の投稿時に、最大126000通りと書きましたが、その時は、演算子と数値を別にせずに9桁の順列でパターンを考えていたので、難しくて概算でだしてました。
 
下記のような方法を考えていました。
上の投稿の順列の生成で、数値と演算子の9桁の順列を出力する。
 
それを逆ポーランド記法での演算アルゴリズムで計算する。式として成立しないものはエラーになるのでそれははじいて、計算結果が答えと一致するものを、を逆ポーランドから通常の中置記法の式に変換する。
ただ、これは無駄が多いです。
 
かすみのさんの数値と演算子を分けるというアイデアは無駄がないのでいいですね。
 
> nは任意の数値(1行内のnはすべて異なるものとする)
> ?は任意の演算子(1行内の?はすべて異なるものとする)
> スペースは区切り文字とする。
>
> とこんな感じ?(9パターン)
 
抜けているパターンがあるような?
 

n n n n n ? ? ? ? 
n n n n ? ? ? n ? 
n n n n ? ? n ? ? ※
n n n n ? n ? ? ? ※
n n n ? ? n n ? ?
n n n ? ? n ? n ? 
n n n ? n n ? ? ? ※
n n n ? n ? n ? ? ※
n n n ? n ? ? n ? ※
n n ? n n n ? ? ?
n n ? n n ? n ? ?
n n ? n n ? ? n ?
n n ? n ? n n ? ?
n n ? n ? n ? n ?

 
の14パターンかな?
※が抜けているパターン
 
> それぞれの文字列を生成して、
 
これは上の投稿と上記のパターンを合わせればでできそうです。
 
> 逆ポーランドの計算部品を用意して結果と比較して…
> 最終的に括弧ありの式に整形して出力すればいける…かしら?
 
これは、13日に作成しました。そこで力尽きて寝てしまいました。
そして、14日は疲れて何もせずです。
 
Dim Stack(10) As Double
Dim StackS(10) As String
Dim SP As Long

Function CalcRPN(ex As String) As Variant
    Dim aryItem As Variant
    Dim V As Variant
    Dim itm As Variant
    
    SP = 0
    aryItem = Split(ex)
    For Each itm In aryItem
        If IsNumeric(itm) Then
            Push (itm)
        Else
            Select Case itm
            Case "=": Exit For
            Case "+": Push (Pop() + Pop())
            Case "*": Push (Pop() * Pop())
            Case "-":
                V = Pop()
                Push (Pop() - V)
            Case "/":
                V = Pop()
                If V = 0 Then
                    CalcRPN = "dived by zero"
                    Exit Function
                Else
                    Push (Pop() / V)
                End If
            Case Else
                CalcRPN = "operator error"
                Exit Function
            End Select
        End If
    Next
    CalcRPN = Pop()
End Function

Sub Push(X As Double)
    Stack(SP) = X
    SP = SP + 1
End Sub

Function Pop() As Double
    SP = SP - 1
    Pop = Stack(SP)
End Function

Function decodeRPN(ex As String) As String
    Dim aryItem As Variant
    Dim V As Variant
    Dim itm As Variant
    
    SP = 0
    aryItem = Split(ex)
    For Each itm In aryItem
        If IsNumeric(itm) Then
            PushS (itm)
        Else
            Select Case itm
            Case "=": Exit For
            Case "+", "-":
                PushS (")" & " " & PopS() & " " & itm & " " & PopS() & " " & "(")
                
            Case "*": PushS (PopS() & " " & itm & " " & PopS())
            Case "/":
                V = PopS()
                If V = 0 Then
                    decodeRPN = "dived by zero"
                    Exit Function
                Else
                    PushS (V & " " & "/" & " " & PopS())
                End If
            Case Else
                decodeRPN = "operator error"
                Exit Function
            End Select
        End If
    Next
    
    For Each itm In Split(PopS())
        decodeRPN = itm & decodeRPN
    Next
End Function

Sub PushS(X As String)
    StackS(SP) = X
    SP = SP + 1
End Sub

Function PopS() As String
    SP = SP - 1
    PopS = StackS(SP)
End Function

 
イミディエイトで確認
?CalcRPN("13 6 - 5 2 * 3 - /")
 1 

?decodeRPN("13 6 - 5 2 * 3 - /")
(13-6)/(5*2-3)

 
逆ポーランドから中置記法の式に変換関数(decodeRPN)は、不必要な()が残る場合があるので、その辺は改良の余地ありです。
 
これで一応必要なパーツはそろっているのであとは、それを組み合わせれば完成できそうです。
 

回答
投稿日時: 17/06/15 23:12:29
投稿者: かすみの

>抜けているパターンがあるような?
おおお、抜けてますね。お恥ずかしい。
 
最終的には逆ポーランド文字列部分も、自動化できるとよいですね。
(n個の整数とm個(n-1個)の演算子)
14個くらいならベタで初期設定でも問題なさげですが。
さらにn>5だと演算子が必ず重複するので本体部分も変えないとですが
 
こんな仕様で大体いけそうな気がします。
 
・先頭要素2つは必ず整数。
・末尾要素1つは必ず演算子。
・再起関数
 ・全ての要素を使い切った文字列を生成したら終了。
 ・現在の要素項目設定
  ・先行する部分の整数項目の数-演算子項目の数-1>0の場合、演算子項目をセット
   →再起で次の項目
  ・整数項目数が残っている場合は、整数項目をセット
   (→整数項目使い切った→残りを演算子で埋めてその系を終了させる。)
   →再起で次の項目
 
()は無くてもそのうち終わりそう。
 
うーん、コード書く体力が残ってない…
やり始めたら一気にできそうな気もするんですけどね…

回答
投稿日時: 17/06/15 23:55:36
投稿者: hatena
投稿者のウェブサイトに移動

simpleさん
> この種の問題は、例えばHaskellなどの関数型プログラムを使うと
> うまく記述できるようです。
 
「関数型プログラム」というワードをあちこちで目にしたことはあります。
どの解説もさっと読んだだけでは難解すぎて、スルーしてました。
おもしろそうなので、余裕があればチャレンジしてみたいですね。
 
 
()の仕様無し、演算子重複なしの場合の、再帰版を作成してみました。
 

Const cNums = "13 2 3 5 6"
Const cAns = 1
Const cOpes = "+ - * /"

Dim aryNums(1 To 120)
Dim aryOpes(1 To 24)

Dim P
Dim U As Long
Dim k As Long

Sub test1() '演算子の重複なし、()は不使用
    Dim i As Long, N, O
    Dim r As Long, s As String

    k = 0
    P = Split(" " & cNums)
    U = UBound(P)
    perm 1, aryNums

    k = 0
    P = Split(" " & cOpes)
    U = UBound(P)
    perm 1, aryOpes

    For Each N In aryNums
        For Each O In aryOpes
            s = N(1) & O(1) & N(2) & O(2) & _
                N(3) & O(3) & N(4) & O(4) & N(5)
            If Application.Round(Evaluate(s), 6) = cAns Then
                'Debug.Print s
                r = r + 1
                Cells(r, 5).Value = s
            End If
        Next
    Next
    Debug.Print "すべてで " & r & " 通り"
End Sub

Private Sub perm(i As Long, aryRes())
    Dim j As Long, t As String
    If i < U Then
        For j = i To U
            t = P(i): P(i) = P(j): P(j) = t
            perm i + 1, aryRes
            t = P(i): P(i) = P(j): P(j) = t
        Next j
    Else
        k = k + 1
        aryRes(k) = P
    End If
End Sub

 
「すべてで 40 通り」となったのでおそらく合っていると思います。
 
前回のコードで、Debug.Print してた部分を、ジャグ配列(配列の配列)に格納するようにしてます。

回答
投稿日時: 17/06/16 01:04:47
投稿者: かすみの

逆ポーランド文字列について追記
 
simpleさんの
>Haskellには代数データ型という強力な概念があり、
 
逆ポーランド型を定義すると…
? : + , - , * , /
n : 数値 , nn?
みたいな感じになるはずなので…
(カンマはor(|)だと思ってください)
 
逆ポーランドの最小単位 nn? の nを nn?で
再帰的に置換していけばパターン出せそうですね
2*3*4=24パターンとなるので、どこかで重複するのでしょうね。
結果をディクショナリに突っ込んでいけばいいかな…(数学的解決をあきらめる人)

回答
投稿日時: 17/06/17 00:32:14
投稿者: hatena
投稿者のウェブサイトに移動

まず最初に、
上の投稿の逆ポーランド→中置記法の式に変換関数(decodeRPN)はバグがありました。
不必要な()が残るというのは認識していましたが、必要な()が出力されないという致命的なバグです。
 
"13 2 5 6 3 / * + -" → "13-(2+5*(6/3))"
が正しい変換ですが、 "(13-(2+5*6/3))"
となってしまいます。
6/3 を囲む括弧がありません。
まあ、優先順位の低い + - だけ囲んでおけばいいだろうという手抜きですので当然ですね。
 
そこでまず、優先順位を考慮して必要な括弧だけつけるロジックを考えました。
変数に前の演算の優先順位を記憶しておいて、それと比較してつけるかどうか判断するなど、いろいろ考えましたが、
結局、スタックに演算式を積むときに、(優先順位, 式) の配列を積むようにして、その優先順位とこれからの演算を比較して括弧を付けるかどうかを判断するようにしました。
 
あと、前回、引数は空白区切りの文字持つで受け取って、Splitで配列に変換して利用してましたが、配列として受け取るように変更しました。CalcRPN の方も同様に配列で受け取るようにしました。また、0除算チェックは、CalcRPN の方でするので、decodeRPN からは削除しました。
 

Dim Stack(10) As Double   '逆ポーランド記法演算(CalcRPN)用スタック
Dim StackS(10) As Variant '逆ポーランド→中置記法変換(decodeRPN)用スタック
Dim SP As Long

'逆ポーランド記法演算
Function CalcRPN(aryItem As Variant) As Variant
    Dim v As Double, itm
    
    SP = 0
    For Each itm In aryItem
        If IsNumeric(itm) Then
            Push itm
        Else
            Select Case itm
            Case "+": Push Pop() + Pop()
            Case "*": Push Pop() * Pop()
            Case "-":
                v = Pop()
                Push Pop() - v
            Case "/":
                v = Pop()
                If v = 0 Then
                    CalcRPN = "dived by zero"
                    Exit Function
                Else
                    Push Pop() / v
                End If
            Case Else
                CalcRPN = "operator error"
                Exit Function
            End Select
        End If
    Next
    CalcRPN = Pop()
End Function

Sub Push(ByVal X As Double)
    Stack(SP) = X
    SP = SP + 1
End Sub

Function Pop() As Double
    SP = SP - 1
    Pop = Stack(SP)
End Function

'逆ポーランド→中置記法 変換
Function decodeRPN(aryItem As Variant) As String
    Dim V1, V2, t As Variant

    SP = 0
    For Each t In aryItem
        If IsNumeric(t) Then
            PushS Array(0, t)
        Else
            V2 = PopS()
            V1 = PopS()
            Select Case t
            Case "+", "-"
                If V2(0) = 2 Then V2(1) = "(" & V2(1) & ")"
                PushS Array(2, V1(1) & t & V2(1))
            Case "*", "/"
                If V1(0) = 2 Then V1(1) = "(" & V1(1) & ")"
                If V2(0) > 0 Then V2(1) = "(" & V2(1) & ")"
                PushS Array(1, V1(1) & t & V2(1))
            End Select
        End If
    Next
    decodeRPN = PopS()(1)
End Function

Sub PushS(ByVal X)
    StackS(SP) = X
    SP = SP + 1
End Sub

Function PopS()
    SP = SP - 1
    PopS = StackS(SP)
End Function

 
イミディエイトで動作チェック
X = Split("13 2 5 6 3 / * + -")
?CalcRPN(X)
 1 
?decodeRPN(X)
13-(2+5*(6/3))
?Evaluate("13-(2+5*(6/3))")
 1 

 
大丈夫のようです。

回答
投稿日時: 17/06/17 01:06:59
投稿者: hatena
投稿者のウェブサイトに移動

さて、これで
 
数値順列生成
演算子順列生成
逆ポーランド記法演算
逆ポーランド記法→後置記法変換
 
すべてのパーツが揃ったので、
あとは、これらを組み合わせて、
逆ポーランド式生成→正答チェック→出力
とすればいいだけです。
 
9桁の逆ポーランド式の14パターンはベタに配列として記述しました。
 

Const cNums = "13 2 3 5 6"
Const cAns = 1
Const cOpes = "+ - * /"

Dim aryNums(1 To 120) '数値順列格納用
Dim aryOpes(1 To 24)  '演算子順列格納用

Dim P                 '要素格納用配列
Dim U As Long
Dim k As Long

Dim Stack(10) As Double   '逆ポーランド記法演算(CalcRPN)用スタック
Dim StackS(10) As Variant '逆ポーランド→中置記法変換(decodeRPN)用スタック
Dim SP As Long
Dim R As Long             '正答件数カウンター

Sub test()    '演算子の重複なし
    Dim i As Long, N, O
    Dim s As String

    k = 0
    P = Split(" " & cNums)
    U = UBound(P)
    perm 1, aryNums

    k = 0
    P = Split(" " & cOpes)
    U = UBound(P)
    perm 1, aryOpes

    Application.ScreenUpdating = False
    Cells.Clear
    Cells(1, 1).Value = cNums
    Cells(1, 2).Value = "答え: " & cAns
    
    R = 0
    For Each N In aryNums
        For Each O In aryOpes
            Check N, O
        Next
    Next
    Debug.Print "すべてで " & R & " 通り"
    Application.ScreenUpdating = True
End Sub

Sub Check(N, O)
    Dim z(1 To 14), i

    z(1) = Array(N(1), N(2), N(3), N(4), N(5), O(1), O(2), O(3), O(4))
    z(2) = Array(N(1), N(2), N(3), N(4), O(1), N(5), O(2), O(3), O(4))
    z(3) = Array(N(1), N(2), N(3), N(4), O(1), O(2), N(5), O(3), O(4))
    z(4) = Array(N(1), N(2), N(3), N(4), O(1), O(2), O(3), N(5), O(4))
    z(5) = Array(N(1), N(2), N(3), O(1), O(2), N(4), N(5), O(3), O(4))
    z(6) = Array(N(1), N(2), N(3), O(1), O(2), N(4), O(3), N(5), O(4))
    z(7) = Array(N(1), N(2), N(3), O(1), N(4), N(5), O(2), O(3), O(4))
    z(8) = Array(N(1), N(2), N(3), O(1), N(4), O(2), N(5), O(3), O(4))
    z(9) = Array(N(1), N(2), N(3), O(1), N(4), O(2), O(3), N(5), O(4))
   z(10) = Array(N(1), N(2), O(1), N(3), N(4), N(5), O(2), O(3), O(4))
   z(11) = Array(N(1), N(2), O(1), N(3), N(4), O(2), N(5), O(3), O(4))
   z(12) = Array(N(1), N(2), O(1), N(3), N(4), O(2), O(3), N(5), O(4))
   z(13) = Array(N(1), N(2), O(1), N(3), O(2), N(4), N(5), O(3), O(4))
   z(14) = Array(N(1), N(2), O(1), N(3), O(2), N(4), O(3), N(5), O(4))

    For Each i In z
        If CalcRPN(i) = cAns Then
            R = R + 1
            Cells(R, 4).Value = decodeRPN(i)
            If Evaluate(Cells(R, 4).Value) <> cAns Then Debug.Print "UnMatch!!"
        End If
    Next
End Sub

'順列生成
Private Sub perm(i As Long, aryRes())
    Dim j As Long, t As String
    If i < U Then
        For j = i To U
            t = P(i): P(i) = P(j): P(j) = t
            perm i + 1, aryRes
            t = P(i): P(i) = P(j): P(j) = t
        Next j
    Else
        k = k + 1
        aryRes(k) = P
    End If
End Sub

'逆ポーランド記法演算
Function CalcRPN(aryItem As Variant) As Variant
    Dim v As Double, itm
    
    SP = 0
    For Each itm In aryItem
        If IsNumeric(itm) Then
            Push itm
        Else
            Select Case itm
            Case "+": Push Pop() + Pop()
            Case "*": Push Pop() * Pop()
            Case "-":
                v = Pop()
                Push Pop() - v
            Case "/":
                v = Pop()
                If v = 0 Then
                    CalcRPN = "dived by zero"
                    Exit Function
                Else
                    Push Pop() / v
                End If
            Case Else
                CalcRPN = "operator error"
                Exit Function
            End Select
        End If
    Next
    CalcRPN = Pop()
End Function

Sub Push(ByVal X As Double)
    Stack(SP) = X
    SP = SP + 1
End Sub

Function Pop() As Double
    SP = SP - 1
    Pop = Stack(SP)
End Function

'逆ポーランド→中置記法 変換
Function decodeRPN(aryItem As Variant) As String
    Dim V1, V2, t As Variant

    SP = 0
    For Each t In aryItem
        If IsNumeric(t) Then
            PushS Array(0, t)
        Else
            V2 = PopS()
            V1 = PopS()
            Select Case t
            Case "+", "-"
                If V2(0) = 2 Then V2(1) = "(" & V2(1) & ")"
                PushS Array(2, V1(1) & t & V2(1))
            Case "*", "/"
                If V1(0) = 2 Then V1(1) = "(" & V1(1) & ")"
                If V2(0) > 0 Then V2(1) = "(" & V2(1) & ")"
                PushS Array(1, V1(1) & t & V2(1))
            End Select
        End If
    Next
    decodeRPN = PopS()(1)
End Function

Sub PushS(ByVal X)
    StackS(SP) = X
    SP = SP + 1
End Sub

Function PopS()
    SP = SP - 1
    PopS = StackS(SP)
End Function

 
問題
5数値 "13 2 3 5 6"
答え 1
 
で、実行してみると、結果は 316通り となりました。
 
Evaluate の結果と比較でも間違いはなく、「重複の削除」コマンドでも重複なしとなりました。
 
たぶん大丈夫だと思われます。

投稿日時: 17/06/17 13:11:11
投稿者: simple

ちょっと諸事多忙でコメントできませんでした。
皆さんからいただいたコメントや、
提示いただいたコード、参考にさせていただくところが多いですね。
 
ところで、参考までにお聞きするのですが、
14のパターンのところもコードで導出するのは結構面倒なものでしょうか。
例えば数値が6個の場合など一般の場合にも適用できるようなものですね。
 
以下、余談です。
こちらにコードを示したのは、あちらの質問に関連して作成して
あったものを、折角ですのでこの機会にと思ったまでです。
ちょっと手を入れた方がよかったかも知れないなあ。
順列作成については手元の本によると4種類ほど手法があるようです。
あちらの質問者さんには不向きでしょうけど。
 
当方も時間をみて継続検討してみたいと思っています。

回答
投稿日時: 17/06/17 14:16:20
投稿者: hatena
投稿者のウェブサイトに移動

simple さんの引用:
ちょっと諸事多忙でコメントできませんでした。
皆さんからいただいたコメントや、
提示いただいたコード、参考にさせていただくところが多いですね。

まったり、じっくり行きましょう。
私の方も、いろいろ参考になったり、刺激を受けたりしました。
 
simple さんの引用:
こちらにコードを示したのは、あちらの質問に関連して作成して
あったものを、折角ですのでこの機会にと思ったまでです。
・・・
あちらの質問者さんには不向きでしょうけど。

私もあの質問を見たときにアイデアは浮かんだのですが、仕様確認してもはっきりしないし、あそこでコードを提示しても逆に質問者さんに迷惑かなと。。。
この手のものは好物なので、質問者さんの存在を忘れて趣味に走ってしまいそうなので。
 
で、こちらに挙げて、正解でした。心置きなく、思う存分、趣味に走れますので。いやー、お陰様で楽しませてもらってます。
 
simple さんの引用:
ところで、参考までにお聞きするのですが、
14のパターンのところもコードで導出するのは結構面倒なものでしょうか。
例えば数値が6個の場合など一般の場合にも適用できるようなものですね。

いろいろ考えてみましたが、
 
数値の数 N
演算子の数 N-1
ある桁までの数値の数 > 演算子の数
 
という縛りがあるので、私の頭ではなかなか難しいです。かすみのさんの
 
かすみの さんの引用:

逆ポーランドの最小単位 nn? の nを nn?で
再帰的に置換していけばパターン出せそうですね

 
というロジックでいけそうな気はしますが、
再帰は直感的にわからないので、
人のコードをみてなるほど、とは思っても、
自分でコードを起こすとなると、私には難しそうです。
 
が、チャレンジしてみたいですね。

回答
投稿日時: 17/06/18 15:10:19
投稿者: カリーニン

面白い記事がありました。
 
小学生でも解けそうなのに引っ掛かる人が続出!? ある学校で配布された算数クイズが秀逸と話題に (ねとらぼ) - Yahoo!ニュース
https://headlines.yahoo.co.jp/hl?a=20170615-00000040-it_nlab-life

回答
投稿日時: 17/06/18 15:22:04
投稿者: カリーニン

↑私、解けませんでした・・・。柔らか頭してないですね・・・。
多湖輝の「頭の体操」読み返さないといけない??

回答
投稿日時: 17/06/18 18:27:47
投稿者: んなっと

n n n n ? ? n ? ? をコードで出すのをトライしてみました。
( )内に?を入れていくと考え、s(1),s(2),s(3)は?の累計個数。
  
n n ( ) n ( ) n ( ) n ( )
  └┘        ↑残りの?は無視
  s(1)個
  └―――┘
    s(2)個
  └――――――┘
       s(3)個 
 
    A   B   C D         E
 1 s(1) s(2) s(3)           
 2   0   0   0   n n n n n ? ? ? ?
 3   0   0   1   n n n n ? n ? ? ?
 4   0   0   2   n n n n ? ? n ? ?
 5   0   0   3   n n n n ? ? ? n ?
 6   0   1   1   n n n ? n n ? ? ?
 7   0   1   2   n n n ? n ? n ? ?
 8   0   1   3   n n n ? n ? ? n ?
 9   0   2   2   n n n ? ? n n ? ?
10   0   2   3   n n n ? ? n ? n ?
11   1   1   1   n n ? n n n ? ? ?
12   1   1   2   n n ? n n ? n ? ?
13   1   1   3   n n ? n n ? ? n ?
14   1   2   2   n n ? n ? n n ? ?
15   1   2   3   n n ? n ? n ? n ?
  
Dim s() As Long
Dim Cnt As Long
Sub test()
  Dim myDic As Object
  Dim Str As String
  Const Num As Long = 5 '数字の個数
  Dim n As Long
  Set myDic = CreateObject("Scripting.Dictionary")
  Cnt = Num - 2 '累計配列s(1),s(2),s(3)の個数
  ReDim s(Cnt + 1) 's(0)とs(4)は、ただのおまけ
  s(Cnt + 1) = Cnt + 1 's(4)は?の個数
  Do Until s(1) > 1
    Str = "n "
    For n = 0 To Cnt
      Str = Str & "n " & WorksheetFunction.Rept("? ", s(n + 1) - s(n)) 's(0)は0
    Next n
    myDic.Add Trim(Str), vbNullString
    Kuriage Cnt
  Loop
  Worksheets.Add.Range("A1").Resize(myDic.Count, 1).Value = WorksheetFunction.Transpose(myDic.Keys())
End Sub
Private Sub Kuriage(i As Long)
  s(i) = s(i) + 1
  If s(1) > 1 Then Exit Sub
  If s(i) > i Then '累計制限を超えたら
    If i > 1 Then
      Kuriage i - 1 '左隣の繰り上げに移行
    End If
  End If
  If i < Cnt Then
    s(i + 1) = s(i)
  End If
End Sub
 
 
数字6個だと42通り出ました。あっているかどうかはわかりません。
 
    A   B   C   D E           F
 1 s(1) s(2) s(3) s(4)             
 2   0   0   0   0   n n n n n n ? ? ? ? ?
 3   0   0   0   1   n n n n n ? n ? ? ? ?
 4   0   0   0   2   n n n n n ? ? n ? ? ?
 5   0   0   0   3   n n n n n ? ? ? n ? ?
 6   0   0   0   4   n n n n n ? ? ? ? n ?
 7   0   0   1   1   n n n n ? n n ? ? ? ?
 8   0   0   1   2   n n n n ? n ? n ? ? ?
 9   0   0   1   3   n n n n ? n ? ? n ? ?
10   0   0   1   4   n n n n ? n ? ? ? n ?
11   0   0   2   2   n n n n ? ? n n ? ? ?
12   0   0   2   3   n n n n ? ? n ? n ? ?
13   0   0   2   4   n n n n ? ? n ? ? n ?
14   0   0   3   3   n n n n ? ? ? n n ? ?
15   0   0   3   4   n n n n ? ? ? n ? n ?
16   0   1   1   1   n n n ? n n n ? ? ? ?
17   0   1   1   2   n n n ? n n ? n ? ? ?
18   0   1   1   3   n n n ? n n ? ? n ? ?
19   0   1   1   4   n n n ? n n ? ? ? n ?
20   0   1   2   2   n n n ? n ? n n ? ? ?
21   0   1   2   3   n n n ? n ? n ? n ? ?
22   0   1   2   4   n n n ? n ? n ? ? n ?
23   0   1   3   3   n n n ? n ? ? n n ? ?
24   0   1   3   4   n n n ? n ? ? n ? n ?
25   0   2   2   2   n n n ? ? n n n ? ? ?
26   0   2   2   3   n n n ? ? n n ? n ? ?
27   0   2   2   4   n n n ? ? n n ? ? n ?
28   0   2   3   3   n n n ? ? n ? n n ? ?
29   0   2   3   4   n n n ? ? n ? n ? n ?
30   1   1   1   1   n n ? n n n n ? ? ? ?
31   1   1   1   2   n n ? n n n ? n ? ? ?
32   1   1   1   3   n n ? n n n ? ? n ? ?
33   1   1   1   4   n n ? n n n ? ? ? n ?
34   1   1   2   2   n n ? n n ? n n ? ? ?
35   1   1   2   3   n n ? n n ? n ? n ? ?
36   1   1   2   4   n n ? n n ? n ? ? n ?
37   1   1   3   3   n n ? n n ? ? n n ? ?
38   1   1   3   4   n n ? n n ? ? n ? n ?
39   1   2   2   2   n n ? n ? n n n ? ? ?
40   1   2   2   3   n n ? n ? n n ? n ? ?
41   1   2   2   4   n n ? n ? n n ? ? n ?
42   1   2   3   3   n n ? n ? n ? n n ? ?
43   1   2   3   4   n n ? n ? n ? n ? n ?

投稿日時: 17/06/18 21:04:41
投稿者: simple

かすみの さん 逆ポーランド記法を使った手法の提案ありがとうございました。
hatena さん 良いパズルをこちらに紹介いただき、ありがとうございました。
カリーニンさん クイズの紹介ありがとうございます。私も引っかかりました。
 
んなっとさん、すばらしいです。
6個の場合、42個ですね。手で確認しました。(アナログ人間ww)
これで完成ということになりますね。
 
さて、以下の話は、ロジックは少し関係してくるかもしれませんが、
VBAの話ではありませんので、
お急ぎの方は、以下まるまるスキップ下さい。
 
◆1
再帰で自動的に表現式を作り出すと言う点に関して、少しメモしてみます。
Haskellという言語を使った話で恐縮です。
 
以下のsplit関数は、リストを二つに分離するすべての方法を再帰を使って
列挙するものです。
 
split :: [a] -> [([a],[a])]
split [] = []
split [_] = []
split (x:xs) = ([x],xs) : [(x:ls,rs) | (ls,rs) <- split xs]
 
例えば、ABCD に対して、 [A,BCD],[AB,CD],[ABC,D] という結果が得られます。
(A〜Dはそれぞれが数値 を示すものと考えて下さい。)
 
複数の要素(例では4つ)からなるリストをもとに、
これを二つに分離する3通りの結果のリストが得られます。
(文法の説明は飛ばしています。すみません)
 
以下の exprs 関数は、
整数のリストから、これと四則演算を使用して得られるすべての表現式を列挙するものです。
 
exprs :: [Int] -> [Expr]
exprs [] = []
exprs [n] = [Val n]
exprs ns = [e | (ls,rs) <- split ns,
                 l <- exprs ls,
                 r <- exprs rs,
                 e <- combine l r]
 
 
・まず、リストns を 上記のsplitを使って二つの部分にわけ、
・それぞれに対して四則演算式を作り、
・その lとr を組み合わせた式 e を得ます。
 
上記の読み方を概括的に説明しますと
   (ls,rs) <- split ns
   は、"split ns の結果からひとつを取り出して、 (ls,rs)に入れる"
   と読みます。
    l <- exprs ls
    は、ls(左要素)に exprsを再帰的に使い、その結果得られる表現式の
    ひとつを l に取り出します。
    r も同様にして作成し、最後に
    e <- combine l r
    で一つの表現式に統合します。
    (しかも conbineの中で、全ての演算子種類を織り込んでいます)
 
exprs ns = ・・・の式は、リスト内包記法と呼ばれるもので、
色々な取り出し方のすべての組み合わせが自動的に作成されます。
ポイントは、途中でexprを再帰的に使って、効果を上げている点です。
この部分がこの処理における重要ポイントになっているかと思います。
 
なお、上記の関数は擬似コードではなく、実際に動作するコードです。
このようにHaskellでは、順番を追って手続きを指示する必要はなく、
こうしたものであると"宣言的に"書けば、
あとは処理系が自動的に作成してくれる点に特徴があります。
 
◆2
Haskellでの手法をそのままVBAに移植するのは困難です。
手続き的にコードを書かないといけないのでとても大変です。
 
オブジェクト指向言語Rubyは、手続き的な言語ということでは
VBAと同じ側に位置しますが、多機能であり、この場合は、
ブロック付きのメソッド呼び出しという機能と、再帰を
組み合わせることで、記述することができます。
Haskellよりも冗長にはなりますが。
 
Haskell,Rubyともに手元に動作するコードはありますが、
そのままVBAへの移植するのは難儀ですので、当面あきらめました。
 
◆3
皆さんの尽力で、VBAを使ってこのゲームを解くことができたと思います。すばらしい。
 
ただ、VBAという制約をはずした場合について少し言及してみました。
実は、今回の件で、Haskellに久しぶりに触りまして、
入門者の域を出ていない事を痛感しました。
また、Rubyはカスタムイテレータについての理解が深まり、よい機会となりました。
ありがとうございました。

回答
投稿日時: 17/06/21 17:09:19
投稿者: hatena
投稿者のウェブサイトに移動

なかなかまとまった時間がとれずにコメントが遅くなりました。
 

simple さんの引用:
このようにHaskellでは、順番を追って手続きを指示する必要はなく、
こうしたものであると"宣言的に"書けば、
あとは処理系が自動的に作成してくれる点に特徴があります。

 
私には難解です。説明を読んでもさっぱり理解できません。
ただ、手続き型だと複雑な処理がシンプルに記述できるということだけは理解できました。
 
関数型プログラミングについていろいろ検索していたら、下記のページを発見。
 
VBAHaskellの紹介 その1 (最初はmapF) - Qiita
http://qiita.com/mmYYmmdd/items/c731edf943acc0a0ebe9#fnref2
 
VBAでHaskellのようことができるライブラリーらしい。時間があったら手を出してみようかな。
 
 
んなっと さんの引用:
n n n n ? ? n ? ? をコードで出すのをトライしてみました。

 
素晴らしいです。私も最初はかすみのさんのロジックでトライしたのですが、再帰が苦手でうまくいかないので、んなっとさんのと同様にnの間にはいる?の数に着目しました。
n n ( ) n ( ) n ( ) n ( )
の前、3つに着目すると、
 
0 0 0
0 0 1
0 0 2
0 0 3
0 1 0
0 1 1
・・・
1 1 1
 
となり4進数表記ととなります。 1 1 1 が最終なので十進数で 21 ですので、22通り、そこから、 「ある桁までの数値の数 > 演算子の数」の条件に外れるものは弾けばいいというロジックを思いつきました。十進数
をN進数へ変換するアルゴリズムは簡単です。
 
ただ、んなっとさんの再帰のロジックのシンプルさには叶いません。?の累計を格納するという発想がなかなか思いつかない。
 
ということで、んなっとさんのロジックを拝借することにしました。
 
まず、んなっとさんのコードではパターンを文字列に変換していますが、文字列では配列に変換しないと利用しづらいので、s() の配列をそのままバリアント配列に格納するようにしました。
 
Dim s() As Long '逆ポーランド記法式パターン 数値間にはいる演算子の累計数
Dim arys()      '式パターンを格納する配列
Dim Cnt As Long

'逆ポーランド記法式のパターン生成
Sub makeRPNPattern(Num As Long)
    Dim i As Long

    Cnt = Num - 2    '累計配列s(1),s(2),s(3)の個数
    ReDim s(Cnt + 1)    's(0)とs(4)は、ただのおまけ
    s(Cnt + 1) = Cnt + 1    's(4)は?の個数
    Do Until s(1) > 1
        ReDim Preserve arys(i)
        arys(i) = s
        i = i + 1
        Kuriage Cnt
    Loop
End Sub
Private Sub Kuriage(i As Long)
    s(i) = s(i) + 1
    If s(1) > 1 Then Exit Sub
    If s(i) > i Then    '累計制限を超えたら
        If i > 1 Then
            Kuriage i - 1    '左隣の繰り上げに移行
        End If
    End If
    If i < Cnt Then
        s(i + 1) = s(i)
    End If
End Sub

 
非常にシンプルです。
 
逆ポーランド記法演算関数(CalcRPN)には、s()配列、数値配列、演算子配列 を引数として渡して、そのまま利用できました。
 
最初の数値と演算子が混ざった配列だと、IsNumericで数値がそれ以外かで処理を分けていましたが、これだと最初から分かれているのでこの条件分けが不要になります。その代わりに数値のForループの中に演算子のForループを入れることでシンプルに記述できました。
 
'逆ポーランド記法演算
'a:演算子挿入数配列 Nums:数値配列 OPes:演算子配列
Function CalcRPN(a, Nums, Opes) As Variant
    Dim v As Double, i As Long, j As Long
    
    SP = 0
    Push Nums(0)
    For i = 1 To 4
        Push Nums(i)
        For j = a(i - 1) To a(i) - 1
            Select Case Opes(j)
            Case "+": Push Pop() + Pop()
            Case "*": Push Pop() * Pop()
            Case "-":
                v = Pop()
                Push Pop() - v
            Case "/":
                v = Pop()
                If v = 0 Then
                    CalcRPN = "dived by zero"
                    Exit Function
                Else
                    Push Pop() / v
                End If
            Case Else
                CalcRPN = "operator error"
                Exit Function
            End Select
        Next
    Next
    CalcRPN = Pop()
End Function
Sub Push(ByVal X As Double)
    Stack(SP) = X
    SP = SP + 1
End Sub
Function Pop() As Double
    SP = SP - 1
    Pop = Stack(SP)
End Function

S()に累計個数が入っているという仕様がうまくはまっています。
 
逆ポーランド→中置記法変換関数も同様に書き換えることができました。

回答
投稿日時: 17/06/21 17:20:00
投稿者: hatena
投稿者のウェブサイトに移動

完成形のコードが下記です。
 

Const cntNum = 5
Const cNums = "13 2 3 5 6"
Const cAns = 1
Const cOpes = "+ - * /"

Dim aryNums(1 To 120) '数値順列格納用
Dim aryOpes(1 To 24)  '演算子順列格納用

'Pern用変数
Dim p                 '要素格納用配列
Dim U As Long
Dim k As Long

Dim Stack(10) As Double   '逆ポーランド記法演算(CalcRPN)用スタック
Dim StackS(10) As Variant '逆ポーランド→中置記法変換(decodeRPN)用スタック
Dim SP As Long
Dim R As Long             '正答件数カウンター

'makeRPNPattern用変数
Dim s() As Long '逆ポーランド記法式パターン 数値間にはいる演算子の累計数
Dim arys()      '式パターンを格納する配列
Dim Cnt As Long

Sub main()    '演算子の重複なし
    Dim N, O, s As String
    '順列生成
    makePerm cNums, aryNums
    makePerm cOpes, aryOpes
    '逆ポーランド記法式のパターン生成
    makeRPNPattern cntNum
    
    Application.ScreenUpdating = False
    Cells.Clear
    Cells(1, 1).Value = cNums
    Cells(1, 2).Value = "答え: " & cAns
        
    R = 0
    For Each N In aryNums
        For Each O In aryOpes
            Check arys, N, O
        Next
    Next
    Debug.Print "すべてで " & R & " 通り"
    Application.ScreenUpdating = True
End Sub
Sub Check(z, N, O)
    Dim a
    For Each a In z
        If CalcRPN(a, N, O) = cAns Then
            R = R + 1
            Cells(R, 4).Value = decodeRPN(a, N, O)
            If Evaluate(Cells(R, 4).Value) <> cAns Then Debug.Print "UnMatch!!"
        End If
    Next
End Sub

'順列生成
Private Sub makePerm(Items As String, aryRes())
    k = 0
    p = Split(Items)
    U = UBound(p)
    perm 0, aryRes
End Sub
Private Sub perm(i As Long, aryRes())
    Dim j As Long, t As String
    If i < U Then
        For j = i To U
            t = p(i): p(i) = p(j): p(j) = t
            perm i + 1, aryRes
            t = p(i): p(i) = p(j): p(j) = t
        Next j
    Else
        k = k + 1
        aryRes(k) = p
    End If
End Sub

'逆ポーランド記法式のパターン生成
'Excel VBA を学ぶなら moug モーグ|ほっとひといき給湯室|VBAつれづれ草
'http://www.moug.net/faq/viewtopic.php?t=75798
'んなっとさんの投稿のコードのロジックを拝借
Sub makeRPNPattern(Num As Long)
    Dim i As Long
    
    Cnt = Num - 2    '累計配列s(1),s(2),s(3)の個数
    ReDim s(Cnt + 1)    's(0)とs(4)は、ただのおまけ
    s(Cnt + 1) = Cnt + 1    's(4)は?の個数
    Do Until s(1) > 1
        ReDim Preserve arys(i)
        arys(i) = s
        i = i + 1
        Kuriage Cnt
    Loop
End Sub
Private Sub Kuriage(i As Long)
    s(i) = s(i) + 1
    If s(1) > 1 Then Exit Sub
    If s(i) > i Then    '累計制限を超えたら
        If i > 1 Then
            Kuriage i - 1    '左隣の繰り上げに移行
        End If
    End If
    If i < Cnt Then
        s(i + 1) = s(i)
    End If
End Sub

'逆ポーランド記法演算
'a:演算子挿入数配列 Nums:数値配列 OPes:演算子配列
Function CalcRPN(a, Nums, Opes) As Variant
    Dim v As Double, i As Long, j As Long
    
    SP = 0
    Push Nums(0)
    For i = 1 To 4
        Push Nums(i)
        For j = a(i - 1) To a(i) - 1
            Select Case Opes(j)
            Case "+": Push Pop() + Pop()
            Case "*": Push Pop() * Pop()
            Case "-":
                v = Pop()
                Push Pop() - v
            Case "/":
                v = Pop()
                If v = 0 Then
                    CalcRPN = "dived by zero"
                    Exit Function
                Else
                    Push Pop() / v
                End If
            Case Else
                CalcRPN = "operator error"
                Exit Function
            End Select
        Next
    Next
    CalcRPN = Pop()
End Function
Sub Push(ByVal X As Double)
    Stack(SP) = X
    SP = SP + 1
End Sub
Function Pop() As Double
    SP = SP - 1
    Pop = Stack(SP)
End Function

'逆ポーランド→中置記法 変換
'a:演算子挿入数配列 Nums:数値配列 OPes:演算子配列
Function decodeRPN(a, Nums, Opes) As String
    Dim i As Long, j As Long, V1, V2

    SP = 0
    PushS Array(0, Nums(0))
    For i = 1 To 4
        PushS Array(0, Nums(i))
        For j = a(i - 1) To a(i) - 1
            V2 = PopS()
            V1 = PopS()
            Select Case Opes(j)
            Case "+", "-"
                If V2(0) = 2 Then V2(1) = "(" & V2(1) & ")"
                PushS Array(2, V1(1) & Opes(j) & V2(1))
            Case "*", "/"
                If V1(0) = 2 Then V1(1) = "(" & V1(1) & ")"
                If V2(0) > 0 Then V2(1) = "(" & V2(1) & ")"
                PushS Array(1, V1(1) & Opes(j) & V2(1))
            End Select
        Next
    Next
    decodeRPN = PopS()(1)
End Function
Sub PushS(ByVal X)
    StackS(SP) = X
    SP = SP + 1
End Sub
Function PopS()
    SP = SP - 1
    PopS = StackS(SP)
End Function

 

投稿日時: 17/06/24 21:11:38
投稿者: simple

VBAHaskellについての貴重な情報ありがとうございました。
作者による、元祖 小町算(Century puzzle)への適用例がありました。
http://qiita.com/mmYYmmdd/items/ebc526a81157f060cc61
参考にさせていただきます。

投稿日時: 17/07/17 22:10:21
投稿者: simple

どうもです。VBA限定ではないのですが、話題提供ということで。
[直感に反する問題]というのが、少し前に Hacker Newsに流れていました。
こんな話です。
 
【問題】

   100人がそれぞれ100ドルを所持しているものとします。
   一定の時間間隔で、各人は所持しているお金を1ドルずつ、
   ランダムに選ばれた(100人中の)他人に与えるものとします。
   これを何度か繰り返したとき、各人の所持金の分布はどうなるでしょう。

100人だと計算も大変なので、
45人が45ドルずつ持っていて、5000回繰り返すものとします。
5000回の後に、お金の分布はどうなるでしょう。
 
----------
なんでも、背景には数理的な話が隠れているようです。
(ちょっと見には)ルールは各人に平等な感じもするんですけどねえ。
頭の体操、コーディングの練習にはなるかもしれません。
リアルタイムでビジュアルなものにすると良いのかも知れませんが、少し面倒かも。
結果から得られるインプリケーションなどありましたら、ご教示いただければ幸いです。

回答
投稿日時: 17/07/18 08:45:15
投稿者: mattuwan44

>これを何度か繰り返したとき、各人の所持金の分布はどうなるでしょう。
単なる勘ですが^^;
一見、「みんな元の所持金に戻る」かなと思いますが、
2割の人が全体の金額の8割を保持し、残りの2割の金額を8割の人で分け合う感じになるとかですかね?

回答
投稿日時: 17/07/18 11:57:54
投稿者: hatena
投稿者のウェブサイトに移動

simple さんの引用:
【問題】
   100人がそれぞれ100ドルを所持しているものとします。
   一定の時間間隔で、各人は所持しているお金を1ドルずつ、
   ランダムに選ばれた(100人中の)他人に与えるものとします。
   これを何度か繰り返したとき、各人の所持金の分布はどうなるでしょう。

100人だと計算も大変なので、
45人が45ドルずつ持っていて、5000回繰り返すものとします。
5000回の後に、お金の分布はどうなるでしょう。

コード自体はそんなに難しくないですね。
今は、実際にコードを作成する時間はないので、
結果を推測だけしてみます。
 
ある一定の幅の正規分布に収束する、となるのでは。
幅は、他人に与える金額によって決まる(金額か大きいほど幅が大きくなる)のでは。
 

回答
投稿日時: 17/07/18 17:17:39
投稿者: hatena
投稿者のウェブサイトに移動

hatena さんの引用:
結果を推測だけしてみます。
 
ある一定の幅の正規分布に収束する、となるのでは。
幅は、他人に与える金額によって決まる(金額か大きいほど幅が大きくなる)のでは。

 
その後、脳内シミュレーションしてみました。
繰り返せば繰り返すほど、正規分布のピークの高さは低くなり、幅が広がっていく、
となりそうな気がしてきました。

回答
投稿日時: 17/07/19 15:34:58
投稿者: mattuwan44

>ランダムに選ばれた(100人中の)他人に与えるものとします。
↑選ばれた1人に他のみんなが1ドル渡すんですかね?

回答
投稿日時: 17/07/19 17:11:40
投稿者: hatena
投稿者のウェブサイトに移動

mattuwan44 さんの引用:
>ランダムに選ばれた(100人中の)他人に与えるものとします。
↑選ばれた1人に他のみんなが1ドル渡すんですかね?

読み方によっては、そういう解釈もできますね。
 
私は、「各人がそれぞれランダムに選んだ他人に渡す」と解釈しました。言葉で書くと曖昧な部分がでますので、コードで書くと下記になります。
 
シートに下記のように入力しておいて、
A1 所持金額
A2 100
A3 100



A101 100
 
Sub Sample1()
    Dim i As Long, j As Long, r As Long
    
    Randomize
    For j = 1 To 100 '100回繰り返し
        For i = 2 To 101
            Cells(i, 1).Value = Cells(i, 1).Value - 1
            Do
                r = Int(100 * Rnd + 2)
            Loop While r = i '自分なら再トライ
            Cells(r, 1).Value = Cells(r, 1).Value + 1
        Next
    Next
End Sub

 
mattuwan44さんの解釈なら、下記のコード
Sub  Sample2()
    Dim i As Long, j As Long, r As Long
    
    Randomize
    For j = 1 To 100
        r = Int(100 * Rnd + 2)
        For i = 2 To 101
            Cells(i, 1).Value = Cells(i, 1).Value - 1
            Cells(r, 1).Value = Cells(r, 1).Value + 1
        Next
    Next
End Sub

回答
投稿日時: 17/07/19 17:14:48
投稿者: hatena
投稿者のウェブサイトに移動

私の解釈のコードを何回か実行して、度数分布グラフを作成してみたら、正規分布にちかいグラフになりました。
また、標準偏差(散らばり具合を表す数値)を計算してみたら、繰り返すほど大きくなるようです。

回答
投稿日時: 17/07/20 13:54:31
投稿者: たらのり

こんにちは
 
■みんなから 1ドルずつ集めて、ランダムに選ばれた一人に
 渡すとする。
 
■途中で手元が 0ドルになってしまった人は、他の人からは
 もらうことはできても他の人にあげることはできない。
 
を前提とみなして予想すると:
 
手元が 0ドルのグループと、元の倍(100人なら 200ドル)を
持つグループに、ちょうと半々に分かれるのではと。
試行回数が多いほど、0ドルと 200ドルからのばらつきは
小さくなるりますホントかよ……
 

回答
投稿日時: 17/07/20 14:04:40
投稿者: mattuwan44

もひとつ、、、
 
>ランダムに選ばれた(100人中の)他人に与えるものとします。
↑自分は除外ってことですよね?

回答
投稿日時: 17/07/20 14:53:53
投稿者: mattuwan44

むー。。。。
 
自分以外の誰かに渡すなら、
 
元の金額近辺で推移しそうですけど、、、、
上手く乱数を1〜99で発生させるのが上手く行かない。。。^^;
j = Int(Rnd * 98 + 0.5) + 1
これじゃ、だめでしたっけ?
1が99になる確率が異常に高そう><

回答
投稿日時: 17/07/20 17:15:09
投稿者: hatena
投稿者のウェブサイトに移動

mattuwan44 さんの引用:
上手く乱数を1〜99で発生させるのが上手く行かない。。。^^;
j = Int(Rnd * 98 + 0.5) + 1
これじゃ、だめでしたっけ?

lowerbound から upperbound までの乱数を発生させるには、下記の式だとヘルプにあります。
 
Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
 
私のコードでは、2行目から101行目までがデータですので(1行目は項目名)
2から101までの整数がランダムに発生すればいいので、
 
Int((101 - 2 + 1) * Rnd + 2)

Int(100 * Rnd + 2)
 
また、自分自身の数字になった場合は、Do Loop で再トライしてます。
 
ですので、ロジック的に問題はないはず。
 
では、なぜ、指向をくりかえすほど、ちらばりが大きくなるかというと、
もう少しモデルをシンプルにして考えてみます。
100人のうち、
50人はそのまま、25人は+1、25人は-1とします。
 
1回目
+1 25
0 50
-1 25
 
2回目も同じ割合で、増減するとします。
+1 の 25人は下記のようになります。
+2 6.25
+1 12.5
0  6.25
 
0 の 50人は
+1 12.5
0 25
-1 12.5
 
-1 の 25人は
0 6.25
-1 12.5
-2 6.25
 
合計すると、
2回目
+2 6.25
+1 25
0  37.5
-1 25
+2 6.25
 
ピークは低くなり、ちらばる幅は大きくなります。これを繰り返せば、ますます、ピークは低く、ちらばりは大きくなるというわけです。
 
これは、現実社会の経済活動をシンプルなモデルでシミュレーションしているのかな、と思いました。
平等な条件で富の移動をさせても、格差はどんどん拡大していくということを示唆しているのかなと。
現実社会では、平等ではなく持てる者の方が有利なので、より格差は拡大すると。(;´・ω・)

回答
投稿日時: 17/07/21 11:38:20
投稿者: mattuwan44

引用:
lowerbound から upperbound までの乱数を発生させるには、下記の式だとヘルプにあります。
  
Int((upperbound - lowerbound + 1) * Rnd + lowerbound)

ありがとうございます。
 
Sub test()
    Dim myCol As Collection
    Dim tmp As Long, tmp2 As Long
    Dim ix As Long
    Dim i As Long
    Dim j As Long

    Set myCol = New Collection
    For ix = 1 To 100
        myCol.Add 100
    Next

    Randomize
    For i = 1 To 100
        For ix = 1 To 100
            j = Int(99 * Rnd + 1)
            tmp = myCol.Item(ix) - 1
            myCol.Remove ix
            tmp2 = myCol.Item(j) + 1
            myCol.Remove j
            If j = 1 Then
                myCol.Add tmp2, , 1
            Else
                myCol.Add tmp2, , , j - 1
            End If
            If ix = 1 Then
                myCol.Add tmp, , 1
            Else
                myCol.Add tmp, , , ix - 1
            End If
        Next
    Next

    For i = 1 To 100
        Cells(i, 1).Value = myCol(i)
    Next
End Sub

 
平均:100
データの個数:100
数値の個数:100
最小値:78
最大値:128
合計:10000
標準偏差:10.588
 
標準偏差がだいたい、8〜12の間くらいになりますが、、、、
ロジックおかしいですかね^^;
コレクションって、値を単に書き換えるって出来ないんですね^^;(いまさら。。。orz)

回答
投稿日時: 17/07/21 13:39:12
投稿者: hatena
投稿者のウェブサイトに移動

mattuwan44 さんの引用:
標準偏差がだいたい、8〜12の間くらいになりますが、、、、
ロジックおかしいですかね^^;
コレクションって、値を単に書き換えるって出来ないんですね^^;(いまさら。。。orz)

ロジックはおかしくないと思います。
ただ、コレクションはオプジェクトを管理するためのものなで、値を更新しようとしたりすると「オブジェクトが必要」と怒られたりするので、配列を使った方がシンプルかなと。
 
標準偏差がだいたい、8〜12の間くらいになるのは、処理回数が100回の固定ですので、当然同じような結果になります。
 
    For i = 1 To 100
       
      '中略

    Next

 
 
 上記の100 を 500 1000 1500 2000 というように増やしていって実行してみてください。
増やすほど、標準偏差は大きくなると思います。
 
処理回数が増えるほど、ちらばりは大きくなるということが分かると思います。

回答
投稿日時: 17/07/21 14:30:14
投稿者: hatena
投稿者のウェブサイトに移動

配列を使った場合のコード例
 

Sub test1()
    Dim i As Long, j As Long, r As Long
    Dim MyAry(1 To 100, 1 To 1) As Long
    
    Randomize
    
    For i = 1 To 100
        MyAry(i, 1) = 100
    Next

    
    For j = 1 To 100 '100回繰り返し
        For i = 1 To 100
            MyAry(i, 1) = MyAry(i, 1) - 1
            Do
                r = Int(100 * Rnd + 1)
            Loop While r = i '自分なら再トライ
            MyAry(r, 1) = MyAry(r, 1) + 1
        Next
    Next
    
    Range("A1:A100").Value = MyAry
End Sub

 
このコードは最初に100に初期化してますが、結果がその都度けっこう差がでますので、
 
投稿日時: 17/07/19 17:11:40 投稿者: hatena
で提示したコードのようにセルに100を100行入力しておいて、
100回ずつ処理するのコードを繰り返し実行して、最大値、最小値、標準偏差、の変化をみるという
やり方の方が変化の様子が分かりやすいですね。

回答
投稿日時: 17/07/21 16:10:52
投稿者: mattuwan44

>標準偏差がだいたい、8〜12の間くらいになるのは、処理回数が100回の固定ですので、
>当然同じような結果になります。
なるほど。。。
 
10万かいでやってみました。
降順で並び替えてみると、だいたい、
上位30人の総資産の合計が約1万。
下位30人が資産マイナスになりそうですね。
間の40人がマイナス分を分け合ってるのかな。。。
なんか怖いですね。。。。。
 

投稿日時: 17/07/22 11:15:13
投稿者: simple

火曜日に帰宅後、インターネットがつながらなくなり、アクセスできませんでした。
結局、外部(VDSL集合装置)の機器故障だったのですが、修理工事が直ぐには行われず、
私も本来不要なトライをしてしまったため、それを元に戻すのが大変でした。
いまやっと回復できたところで、ほっとしています。
こんなことがあるんだなあ、というやるせない気持ちもあります。
 
皆さんのご発言にタイムリーにお応えできず、ご迷惑お掛けしました。
 
また、私の翻訳力不足のためか、正確な解釈がしにくいものだったようです。
問題の原文は、

  Imagine a room full of 100 people with 100 dollars each. 
  With every tick of the clock, every person with money 
  gives a dollar to one randomly chosen other person. 
  After some time progresses, how will the money be distributed?
というものでした。
 
Hacker News記事は
https://news.ycombinator.com/item?id=14729400
元記事は↓です。
http://www.decisionsciencenews.com/2017/06/19/counterintuitive-problem-everyone-room-keeps-giving-dollars-random-others-youll-never-guess-happens-next/
 
hatenaさんはじめ皆様から適切なコメントをいただいたものと思います。
直感では、平等にやりとりするんだから、初期時点の分布が保たれるんじゃないかと
思いがちだろうということで、題名 counterintuitive problemと名付けたものと思います。
 
(なお、自分の所持金が0になれば他人に与えることはできない、借り入れということは
  考えないという積もりのようです。)
 
また、元記事で参照している
http://physics.umd.edu/~yakovenk/papers/EPJB-17-723-2000.pdf
によれば、物理の世界で知られている Boltzmann分布になるのではないかと言っているようです。
これは、「エネルギーが保存され、互いの粒子がエネルギーをやりとりする系において
エネルギーがεの粒子の確率分布はP(ε) = C・exp(−ε/T) (Tは温度、Cは正規化定数)」
となるというものです。
今回のものは、エネルギーをマネーと考え、Tを一人当たり平均マネーとした場合の
上記分布に従うと言っているようです。
 
> これは、現実社会の経済活動をシンプルなモデルでシミュレーションしているのかな、と思いました。
> 平等な条件で富の移動をさせても、格差はどんどん拡大していくということを示唆しているのかなと。
そうだと思います。
その一方で、富めるものもいつかは貧しいものになりうるし、反対もしかりのようで、原理的にはどの状態も互いに移行可能ということのようです。
ただ実感としては、少なくとも人間の1世代というような時間的スパンでは、
必ずしもそうした理論どおりにはならず、貧富が固定化しつつあるような気はしています。
 

回答
投稿日時: 17/07/28 11:53:18
投稿者: めんたん

雑談スレか迷いましたが、VBAがらみだったのでこちらに書き込み。
  
以前ここの掲示板でVBEのコードに自動でインデントを付けるアドオンを紹介されている記事があったと思うのですが、なんというアドオンを紹介されていたか分かる方いらっしゃいますか?
PC引越しで紛失してしまって探しています。
  
ネットで検索してみると「Smart Indenter」なんていうのが引っかかるのですが、これじゃなくてもっとシンプルだった。。(気がする・・)
へるぷみ〜

回答
投稿日時: 17/07/28 13:45:33
投稿者: めんたん

「Smart Indenter」を入れてみたら、これだった気がしてきた!
 
┌|∵|┘解決〜

投稿日時: 17/07/29 15:48:09
投稿者: simple

解決済みのようですけど、宣伝しておきましょう。関係者ではないですが。
smart indenter
http://www.oaltd.co.uk/Indenter/Default.htm
こちらですね。便利なアドインです。
私は、回答する際に、まずはこれで整形してから読んでいます。
こんな風に整形した方がいいですよ、と提示するときも、
これでワンクリックで済みますから、
私にとってある意味、必需品ですねえ。
 
余談:
長いことこちらで回答者をしているけれど、
ご自分のやりたいことの説明もせずに、
コピペして使いたいコードの説明をしてくれ、という質問は初めてですね。
これにもインデントの重要性を語っておきました。
まずはやりたいことをきちんと提示して欲しいですね。

投稿日時: 17/07/30 10:14:07
投稿者: simple

他の質問掲示板の話題です。
ホームページの決まった場所へアクセス
http://www.excel.studio-kazu.jp/kw/20170727202418.html
 
これは、技術的にはさほど難しくないんじゃないかと感じました。
・Javascript系を使った動的な要素はなく、すべて静的に決まっているリンクを
  辿っていけるものですし、HTMLテキストを順次取得すればよいだけでしょう。
  (気をつけるのは、UTF-8の文字コード対応くらいでしょうか)
・正規表現を使えば、取り込んだソースを分析して、
  各歯医者さんのURIや、
  医院名、電話番号、所在地、ホームページの情報
  を取得するのは比較的容易です。
 
ただ、何より業務上の手間を丸投げで省こうというのが安易過ぎると思いましたし、
その点からも「ちょこっと掲示板で書いてあげるレベルではないので、
どこか有料で作成してくれるところで頼んだほうがよろしいかと思います。 」
というのも良い仕切りかなと思いました。
 
さて、ここで皆さんにご意見を頂戴したいと思います。
こうしたケースで、リンク先の取得や、必要項目の取り出しには
・DOMを分析していく手法
・HTMLテキストを取得して正規表現で分析する手法
の二つがあると思いますが、皆様はどちらをお薦めですか?
・実行時間
・作成に要する時間
・必要とされるスキル
などの点があるかと思います。

投稿日時: 17/08/01 20:44:14
投稿者: simple

(1)
【VBAでインターネット上のファイルをダウンロードする方法をまとめてみました。】
https://www.ka-net.org/blog/?p=4855
が参考になると思います。
 
なかでも、
「WinHttpRequest(XMLHTTPRequest) + ADODB.Streamを使ってファイルをダウンロードする方法」が私が慣れている方法ですね。
 
# この記事にある、YU-TANGさんのWebページは現在ではリンク切れになっています。
# YU-TANGさんがサイトを閉じるにあたって、関連ファイルをZipで皆さんに提供されたことがあり、
# 私は今でも時々参照しています。
 
(2)
さて、私は今までXMLHTTPRequestだけ使ってきましたが、
YU-TANGさんの記事によると、
WinHttpRequest は XMLHTTPRequestよりも後発のものだそうです。
 
私は、XMLHTTPRequest で responseBody を ADODBに取り込んだ後、
文字コードを指定してテキストで読み込むという方法を採っていました。
(きぬあささんのコードとほぼ同等です)
 
しかし、今回、WinHttpRequestを使ってみたところ、
文字コードの修正を特に行わなくても、UTF-8 も Shift_JISも取得することができました。
(下記コード参照)
 
これって本当? 今までのADODB利用は何だったんだろう。
というのが今回の発見の一つでした。
(たまたまうまくいっただけということでしたら、ご指摘願います)
 
' HTMLテキストを取得する

Dim oHttp   As Object
Sub test1()
    Dim buf     As String
    Dim url As String

    url = "http://www.haishasan.net/haisha_html/sagase/tokyo/"
    Set oHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    buf = getHTMLtext(url)
    Stop
End Sub

Function getHTMLtext(url As String) As String
    With oHttp
        .Open "GET", url, False
        .send
        If .Status = 200 Then
            getHTMLtext = .responseText
        Else
            MsgBox .Status & " : " & .statusText
        End If
    End With
End Function
いったん、ここまでにします。

投稿日時: 17/08/05 11:24:05
投稿者: simple

(1)
前回こう書きました。

引用:
しかし、今回、WinHttpRequestを使ってみたところ、
文字コードの修正を特に行わなくても、UTF-8 も Shift_JISも取得することができました。
これって本当? 今までのADODB利用は何だったんだろう。
時間がとれたので、検証してみました。
 
<HTML>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
</head>
<BODY>
テストです。
</BODY>
</HTML>
のような簡単なテキストをダウンロードして、
HttpRequest.responsetextで取得してみると、やはり文字化けが起きました。
そう簡単な話ではなかったようです。
 
想像ですが、ある程度大きいテキストでないと、自動判定ができないのかもしれません。
(そういえば、ADO の Streamオブジェクトを使って、
  .charset に _autodetect_all をセットしておくと、
  文字コードを自動判定してくれるということです。
  ただこれも、文字数が少なかったりすると、判定が不能になるということでした。
  たぶんこれと同じような事情なんでしょう。)
 
仮結論:
・WinHttp.WinHttpRequest.5.1 の .responsetextはある程度の長さのテキストでないと
文字判定ができないようだ。
・やはり、responsebodyをもとに、ADO.Streamで文字コード指定するのが間違いが無い。

(2) 余談の余談
そういえば、昔、XMLHTTPRequest + ADODB.Streamを使って、
こちらのサイト(moug)をダウンロードするVBAコードを給湯室に載せたことがある。
 
その時、他の投稿者のかたから、ADO.Streamなぞ使わなくても、
    StrConv(HttpRequest.responsebody, vbUnicode)
でいいじゃないか、との発言があり、
不覚にも確認せず、そうですねと言ってしまったのが今でも悔やまれる。
ためしてみるとわかるが、うまくいきません。
(もう10数年前の話だが、未だに記憶にある)
 
また、ここでいったん区切ります。
# 茶々入れ歓迎します。

回答
投稿日時: 17/08/14 22:35:51
投稿者: mmYYmmdd

こんばんは。
ちょっと前にVBAHaskellのことが出ていたので、「100人が1ドルずつランダムに配る問題」をVBAHaskellでやってみました。
 

' 100人が100ドルをどうたらこうたら
    ' initDollar : 最初の持ち金
    ' members    : 人数
    ' it         : 繰り返し回数
Function random_donate(ByVal initDollar As Long, _
                           ByVal members As Long, _
                               ByVal it As Long) As Variant
    Dim persons As Variant
    persons = repeat(initDollar, members)    ' 持ち金の初期配列
    Dim i As Long
    For i = 1 To it Step 1
        ' 乱数列[1, 人数-1]を与える
        persons = give_1_dollar(persons, uniform_int_dist(members, 1, members - 1))
    Next i
    Call swapVariant(random_donate, persons)
End Function

' 1回のセッション
Function give_1_dollar(ByRef persons As Variant, ByRef targets As Variant) As Variant
    Dim i As Long, tgt As Long
    For i = LBound(persons) To UBound(persons) Step 1
        If 0 < persons(i) Then
            tgt = (i + targets(i)) Mod sizeof(persons)  ' 自分以外の誰かに
            persons(tgt) = persons(tgt) + 1
            persons(i) = persons(i) - 1
        End If
    Next i
    Call swapVariant(give_1_dollar, persons)
End Function

「uniform_int_dist」は個数と範囲を与えてランダムな整数値を配列で返す関数です。
たとえばこんなパラメータで計算してみます。
m = random_donate(100, 100, 1000)    ' 100ドル  100人  1000回

サイズや中身の確認
printS m
[Dim1]: 0 -> 99  : Total Size = 100
printM m
  111  79  108  66  64  94  120  116  123  89  94  97  130  43  67  136  96  71  103  112  143  117  60  215  47  84  115  127  112  94  85  148  131  54  100  110  32  126  127  95  92  118  125  109  81  67  102  69  94  122  114  83  89  122  117  61  152  151  61  81  111  47  122  82  80  111  99  134  74  125  147  130  116  78  113  112  84  138  104  120  100  127  119  93  154  41  162  98  83  53  28  97  120  93  72  42  66  48  114  112

統計値はこんな感じで計算できます
最小値と最大値
? foldl1(p_min, m), foldl1(p_max, m)
 28            215 
分散と標準偏差
s2 = foldl1(p_plus, mapF(p_mult, mapF(p_minus(, 100), m))) / 100
?s2, s2 ^0.5
 999.14        31.6091758829616 

本体部分にあまりVBAHaskellらしさは出せませんでした。
お目汚し失礼しました。

投稿日時: 17/08/16 05:40:31
投稿者: simple

おお、VBAHaskellの作者さんから直々のコメントをいただき恐縮です。
動作確認させていただきました。
かなり高速で動作している感触です。
どうもありがとうございます。
取り急ぎ御礼まで。
# 法事やら何やらで取り紛れておりました。

回答
投稿日時: 17/09/07 16:07:41
投稿者: George

VBAネタとして。
 
近々、私の職場で端末をWindows 10にするのに伴って
Office 2010 → Office 2016 になるのですが、
皆さんの環境下で同じような移行をしたときに
今まで動いていたマクロが動かなくなったとか
こういう風に回収する必要があると言った情報が貰えたら
以後の回収スケジュールを立てるのに役立てたいと思います。
 
些細なことでも良いのでお願いします。

回答
投稿日時: 17/09/10 09:20:20
投稿者: mr_hige
メールを送信

George さんの引用:
VBAネタとして。
 
近々、私の職場で端末をWindows 10にするのに伴って
Office 2010 → Office 2016 になるのですが、
皆さんの環境下で同じような移行をしたときに
今まで動いていたマクロが動かなくなったとか
こういう風に回収する必要があると言った情報が貰えたら
以後の回収スケジュールを立てるのに役立てたいと思います。
 
些細なことでも良いのでお願いします。

依然はあまりなかったことですが、Excel2016 時々クラッシュ、頻度が増加しましたね。
夢中になって操作していて、何かのリボンをマウスでクリックしようとしたとき、突然やってきます。
<<Windows 10にするのに伴って、Office 2010 → Office 2016>>に関係してるかどうかは分かりませんが・・・

回答
投稿日時: 17/09/12 10:24:49
投稿者: George

mr_higeさん ありがとうございます。

mr_hige さんの引用:

依然はあまりなかったことですが、Excel2016 時々クラッシュ、頻度が増加しましたね。
夢中になって操作していて、何かのリボンをマウスでクリックしようとしたとき、突然やってきます。
<<Windows 10にするのに伴って、Office 2010 → Office 2016>>に関係してるかどうかは分かりませんが・・・

これは、WindowsUpdateを最新の状態にしても発生するようなクリティカルなものでしょうか?

回答
投稿日時: 17/09/16 16:06:37
投稿者: mr_hige
メールを送信

<<WindowsUpdateを最新の状態にしても発生?>>
一番新しい状態になっています。
でもたまに起こります。なので上書を意識しています。
ただし、Win10が関係してるかどうかは私にはわからないのですが。

回答
投稿日時: 17/09/18 12:34:24
投稿者: George

クラッシュというのは、ファイルが破損するという意味ではないのですね?
アプリケーションが強制終了してしまうということで良いのでしょうか?
 
いずれにしても既にかなりの月日が流れていますが、
今でもクラッシュとの戦いを強いられるということなのでしょうか?
 
それはどのようなシチュエーションでクラッシュすることが多いのでしょうか?
例えば普通にデータ入力してても出るものなのか、シートの再計算などで処理が重いと出るものなのか
などまだまだ知りたいことが多いです。

回答
投稿日時: 17/10/04 10:32:10
投稿者: sk

引用:
近々、私の職場で端末をWindows 10にするのに伴って
Office 2010 → Office 2016 になるのですが、
皆さんの環境下で同じような移行をしたときに
今まで動いていたマクロが動かなくなったとか
こういう風に回収する必要があると言った情報が貰えたら
以後の回収スケジュールを立てるのに役立てたいと思います。

Office Support Team Blog JAPAN:
https://blogs.technet.microsoft.com/officesupportjp/
 
Japan Office Developer Support Blog:
https://blogs.msdn.microsoft.com/office_client_development_support_blog/
 
公式的なアナウンスについては、以上のブログを
定期的にチェックしておくことをお奨めします。
 
また、Microsoft コミュニティや MSDN の VBA フォーラム等に
挙がっているスレッドを参考にするのもよいでしょう。
 
なお、Office 2016 に関しては現在、先日の更新によって発生した
以下の現象が炎上案件となっています。
(まだ修正されていない)
 
Japan Office Developer Support Blog より:
https://blogs.msdn.microsoft.com/office_client_development_support_blog/2017/08/23/ver1708-issue-japanesenamevbamodule/
 
MS コミュニティより:
https://answers.microsoft.com/ja-jp/msoffice/forum/msoffice_access-mso_win10-mso_2016/access2016/f7dc70ee-e228-473e-a92e-17992a3b16b3
 
C2R 版の Office 2016 の導入に差し当たって
今のところ申し上げられるのは、
「 Office の自動更新を無効にしておこう」
ということです。

回答
投稿日時: 17/10/04 13:58:52
投稿者: sk

sk さんの引用:
(まだ修正されていない)

などと言ってたそばから続報が。
 
Japan Office Developer Support Blog より:
https://blogs.msdn.microsoft.com/office_client_development_support_blog/2017/08/23/ver1708-issue-japanesenamevbamodule/
 
引用:
2017/10/4 Update
Monthly Channel に修正されたバージョンを公開しました。

回答
投稿日時: 17/10/05 15:05:19
投稿者: mattuwan44

>クラッシュというのは、ファイルが破損するという意味ではないのですね?
>アプリケーションが強制終了してしまうということで良いのでしょうか?
 
クラッシュというと個人的には、
ハードディスクの破損や、OSの損壊によりそのままでは再起動不可能な状態を想像しますね。
 
アプリケーションの異常終了も含むようですが、アプリケーションの損壊や
データの損壊を伴う場合でしょう。
アプリケーションが強制終了されて、今入力したものが保存されてない程度はクラッシュっていうのかなぁ。。。
エクセル2000の頃はアプリケーションエラーによる異常終了は頻繁にあったので、
「また、アプリケーションエラーで打ち直しかぁ(T^T)」ってのは、
慣れているというかなんというか。。。
(自費で2003にバージョンアップして快適になったのは2007が出た後><)
 
WinXP+Excel2003で何の支障もない人が大半だと思うのですが、
ハードもソフトもどんどん高性能になってますね^^;
2013を使う前に2016が出ちゃってますもんねー。。。
自宅のPCはOSのクリーンインストール後Excel2003だけ入れて他のソフトは入れてないなー。。。
 
パソコンの高性能化よりネットの通信速度の高速化+安定化の方をしてほしいです^^;
1G謳って2Mしかでてないって・・・(;_;)

回答
投稿日時: 17/10/05 20:01:13
投稿者: mr_hige
メールを送信

George さんの引用:
クラッシュというのは、ファイルが破損するという意味ではないのですね?
アプリケーションが強制終了してしまうということで良いのでしょうか?

大変失礼しました。
私の感覚で言いましたが、破損ではありません。
『潰れてペチャンコ』にはなるけれど、また膨らませれば概ね復活する―――こんな感じなのかな。
勝手な解釈ですよ。
考えてみれば、クラッシュしたというときは復活しそうもない状態ですよね。私の使い方が間違っているかもしれません。
 
日常生活に横文字が多いですね。わからない言葉が沢山あります。
『日本語で言えばいいのに』と我が家の神様。
その通りだと私も思うのですが、思う自分も使ってますね。
日本語にするのが難しい感じがあります。
でも横文字でなくともよいのに、わざわざ使ってるのではないのかな、と思うときもあります。

回答
投稿日時: 17/10/24 14:32:01
投稿者: mattuwan44

う〜ん。
 
70枚のシートをシート名で降順から昇順へ並び替えようと思ったんですが
(PDFファイルにするため)、
切羽詰るとマクロ考えるより手動でやってしまいますね^^;
 
もう用はないけど折角書いたので^^;
 

Option Explicit

Sub testメイン()
    SortOfSheets ThisWorkbook
End Sub

Sub SortOfSheets(ByVal wb As Workbook, _
                 Optional ByVal flg As Boolean = True)
    Dim shs As Sheets
    Dim sh As Worksheet
    Dim ws As Worksheet
    Dim i As Long

    Application.ScreenUpdating = False
    
    Set shs = wb.Worksheets
    For Each sh In shs
        For i = shs.Count To 2 Step -1
            Set ws = wb.Worksheets(i)
            If flg = (sh.Name > ws.Name) Then
                sh.Move after:=ws
                Exit For
            End If
        Next
    Next
    wb.Worksheets(1).Select
End Sub

 
暇があれば日付形式のシート名にでも対応したいけど。。。。

回答
投稿日時: 17/11/14 09:43:45
投稿者: mattuwan44

ActiveWindow.DisplayFormulas = True
 
のとき、
数式が2次元配列に一括で代入できますね。。。
常識でした?

回答
投稿日時: 17/11/14 19:08:25
投稿者: baoo

ActiveWindow.DisplayFormulasというのは初めて知りましたが、
2次元配列に数式を一括で代入というのはどういうことですか?
元々Range("C3:F6").Formulaが数式の2次元配列なので
ActiveWindow.DisplayFormulasとは関係なく代入できると思います。
 
ActiveWindow.DisplayFormulas=Trueはシート上に表示されるのが計算結果ではなく、
計算式そのものに切り替わるものだと思います。
 

回答
投稿日時: 17/11/15 08:29:36
投稿者: mattuwan44

>元々Range("C3:F6").Formulaが数式の2次元配列なので
>ActiveWindow.DisplayFormulasとは関係なく代入できると思います。
あれー
 
こちらの勘違いでした?
なんだろー。エラーにならないけど、何も代入されなかったような気が。。。
 
Sub test()
    Dim vv As Variant
     
    vv = Range("A1").CurrentRegion.Formula
     
    Range("A20:C30").Formula = vv
     
End Sub
 
いまやったら、普通に出来ますね^^;
2次元配列に代入出来るのはValueプロパティだけかと思ってました。。。
ありがとうございます。
 
Textプロパティも出来るといいのになぁ。。。

回答
投稿日時: 17/11/21 19:44:30
投稿者: baoo

http://www.moug.net/faq/viewtopic.php?t=76432
の画像の回転の件ですが、ネットで探してみるとPlgBltというアフィン変換の関数が
使えるようでした。
それでこの関数に指定する3点が問題なのですが、幅w、高さhの画像を考えると、
原点は(0,0)、X軸方向の点は(w,0)、Y軸方向の点は(0,h)になります。
この画像を90度回転した場合を考えますと、原点は(h,0)、X軸方向の点は(h,w)、
Y軸方向の点は(0,0)へ移動します。
PlgBltに指定する3点はpt(0)が移動後の原点、pt(1)が移動後のX軸方向の点、
pt(2)が移動後のY軸方向の点になります。
 
それでさらにBitBltを使ってフォーム上に描画はできたんです。
しかしネットから探してきたOleCreatePictureInDirectという関数を使っても
Imageコントロールには表示されません。
このOleCreatePictureInDirectについてのコードは、ほぼネットからのコピペで
使いこなしてる感が無く、私の今後の課題なのですが
そうはいってもデバック実行でエラーが発生している様子もありません。
 
それでAbyss2さんのコードを眺めているとなるほどBitmapオブジェクトを
使っているんだなと思ったんですが、その時たしかGDI+ではBitmapオブジェクトから
Bitmapハンドルに変換するやつやその逆の奴があることを思い出したんです。
それでAbyss2さんのコードを変更してBitmapオブジェクトからBitmapハンドルに
変換してOleCreatePictureInDirectを呼び出してみました。
一発で表示されました。
 
ということは私のコードでのBitmapハンドルがよろしくないということです。
で自分のコードを眺めてみると使っていたのは描画前のBitmapハンドルでした。
これ、うっかりじゃなくてですね、SelectObjectの後にBitBltなどで描画した場合、
そのBitmapハンドルにも描画したのが適用されると勝手に思ってたんですね。
結論から言えば私が分かっていたつもりが分かっていなかったということです。
 
それで、じゃあ描画後のBitmapハンドルを取得すれば良いわけですが、
それが分からない。
いやー、今考えるとアホなんですが、ネットで探しまくりました。
それから手持ちのAPI本で調べたりもしました。
で、分からずに自分のコードを眺めていて気づいたのですが、
SelectObjectの戻り値はそれまでのBitmapハンドルなので、
描画前のBitmapハンドルを適用したときの戻り値を描画後に
再度戻してやればその戻り値が描画後のBitmapハンドルになるはず。
頭ではわかってたんですが、今までは使ったら戻すという意味でしか考えず、
再利用することなんて考えてもいなかったんですね。

回答
投稿日時: 17/12/15 20:12:28
投稿者: baoo

少し前の下記の件ですが、
http://www.moug.net/faq/viewtopic.php?t=76538
ちょっと気になることがあります。
この方が言っていた変わったというのは私にとっては既に普通のメッセージボックスとして
認識しているものになっていたので結論としては問題ないんですが、
じゃあ、Windows7の頃の表示はできないのかというのを少し調べていたんです。
そりゃ、Windowsのウィンドウの表示がWindowsのバージョンに合わせて変わって行くのは
今までの通りです。
Windowsの方で変わってしまったんだから仕方ないとも思うのですが、
私が気になっているのはVBE上にユーザーフォームを挿入したときの表示です。
私はWindows10でOffice2013をメインに使っているのですが、
挿入時のユーザーフォームはWindows7の頃のような表示なんですね。
 
このユーザーフォーム、単なる描画ではなくちゃんとウィンドウハンドルも持っていますし、
ウィンドウスタイルを変更するとそれに合わせて表示も変更されます。
昔調べたときの記憶で実行時のウィンドウハンドルも同じまま(両者は同じ)と思っていましたが、
それは私の記憶違いで、結局別のウィンドウですね。
 
挿入時のウィンドウスタイル、拡張ウィンドウスタイルを実行時の
ユーザーフォームに適用してみましたが、それでは挿入時の表示にはなりませんでした。
同じThunderDFrameなんですけどね。
 

投稿日時: 18/04/14 20:07:57
投稿者: simple

別の質問掲示板ですが、処理速度の測定にあたって、
CDbl(Timer) というように、TimerをDoubleに変換したものが使われていました。
Timer関数はもともとSingle値を返すので、どんな意味があるんでしょうか。
 

Sub test()
    Dim t As Single
    Dim d As Double
    t = Timer
    d = t
    Debug.Print t  ' 出力  72056.74 
    Debug.Print d  ' 出力  72056.7421875 
End Sub
としたときに、端数にある21875というのは意味があるでしょうか。

回答
投稿日時: 18/04/15 00:28:05
投稿者: sy

simple さんの引用:
Timer関数はもともとSingle値を返すので、どんな意味があるんでしょうか。
    Debug.Print t ' 出力 72056.74
    Debug.Print d ' 出力 72056.742187
としたときに、端数にある21875というのは意味があるでしょうか。

私もDoubleを使います。
私の場合は特別な意味は無く使い分けるのがめんどくさいので、単に整数はLong、少数はDouble、と使ってるだけです。
記述方法は私は宣言部でDouble型にして、t=timer と言った記述にするとかの違いはありますけど。
時間計測でVariant型を使った事は無いけど、どっちにしても t=timer と記述すると思います。
 

回答
投稿日時: 18/04/15 10:49:32
投稿者: hatena
投稿者のウェブサイトに移動

simple さんの引用:
Sub test()
    Dim t As Single
    Dim d As Double
    t = Timer
    d = t
    Debug.Print t  ' 出力  72056.74 
    Debug.Print d  ' 出力  72056.7421875 
End Sub
としたときに、端数にある21875というのは意味があるでしょうか。

 
SingleからDoubleへ変換する時の変換誤差だと思います。
どのようなロジックで変換しているか分かりませんが、
下記のコードの結果からの推測です。
 
Public Sub test()
Public Sub sdtest()
    Dim s As Single
    Dim d As Double
    
    s = 72056.74
    d = s
    Debug.Print s; "     Single"
    Debug.Print d; "Single to Double"
    
    d = 72056.74
    Debug.Print d; "     Double"    
End Sub

 
イミディエイトの出力
 72056.74      Single
 72056.7421875 Single to Double
 72056.74      Double

 
よって、Single を Double に変換するのは、余計な誤差を付加するだけで、
無意味だと思いますが、どうでしょうか。

投稿日時: 18/04/15 20:00:36
投稿者: simple

sy さん
hatena さん
コメントありがとうございました。
hatena さんのご意見に同意します。
 
ところで、過去の発言を調べてみましたら、
kanabunさんが、 15/05/19 15:10:02に
「Timer()関数の精度について 」というスレッドを立ち上げて、同様の疑問を提示していました。
 
いくつか要約してお伝えします。
 
(1)タイマの精度は相当に粗い。singleで扱える程度の有効桁数以上の桁数にはもともと余り意味がない。
 

kuni0416 さんの引用:
Windows のタイマの精度は、55 ミリ秒に制限されているようですので、有効ではない可能性があるかと思います。
引用:
引用:
Windows のタイマは、処理に UI スレッドを使用するシングルスレッド環境用にデザインされています。Windows のタイマの精度は、55 ミリ秒に制限されています。これらの従来のタイマは、UI メッセージ ポンプを可能にするユーザー コードを必要とします。さらに、ユーザー コードを常に同一のスレッドから処理するか、または呼び出しをほかのスレッドに集約する必要があります。COM コンポーネントで従来のタイマを使用すると、パフォーマンスが低下します


kanabun さんの引用:
参考記事
http://qa.atmarkit.co.jp/q/1169
http://hanatyan.sakura.ne.jp/vbhlp/GetTime.htm

 
関数の戻り値の型が「単精度浮動小数点数型」とあるため、倍精度浮動小数点型で受けても精度は保障されないのではないかと思います。 (kuni0416さん)
 
(2)
kanabun さんの引用:
これでいいみたいですね
 
Sub tryCurr2()
    Dim t1 As Currency
    Dim t2 As Currency
     
    t1 = CStr(Timer())
    Application.Wait Now() + TimeValue("0:00:02")
    t2 = CStr(Timer())
    Debug.Print "t1 "; t1
    Debug.Print "t2 "; t2
    Debug.Print "t2-t1 "; t2 - t1
End Sub
 
単純に
 t1@ = Timer()
と直接代入すると、 t1 = 28133.0391 などのように夾雑物がついて
 しまうので、
    t1 = CStr(Timer())
といちど文字列化してから、貨幣型(固定小数点型)に代入しています。

 
CDblで変換する意味が乏しいことはかなり正しいと思いますが、
ここまでやるかは意見が分かれるかもしれませんね。
個人的には、
dim t 
t = Timer
' ここで作業
Debug.Print Timer - t 

と簡単なコードにしておいて、結果の細かいところは余り重視しない、
という折衷案(というか、今まで私がとっていた方法ですな)で行こうかなどと
考えています。
 
なお、そういうことではイカンという向きには、こちら↓をご参考に。
kanabun さんの引用:
非常に短い経過時間(1秒前後)を求めるなら API か
kuni0416 さんの言われている
> QueryPerformanceCounter
ですね
(みてみると、関数の引数のデータ型 やっぱり Currency でした!)

回答
投稿日時: 18/04/16 12:01:17
投稿者: hatena
投稿者のウェブサイトに移動

simple さんの引用:
なお、そういうことではイカンという向きには、こちら↓をご参考に。
kanabun さんの引用:
非常に短い経過時間(1秒前後)を求めるなら API か
kuni0416 さんの言われている
> QueryPerformanceCounter
ですね
(みてみると、関数の引数のデータ型 やっぱり Currency でした!)

 
そういうことではイカンという向きなので、
以前、QueryPerformanceCounter を使って高精度な時間計測関数を作成してブログで公開してます。
 
VBAでミリ秒以下の高精度で処理時間計測 - hatena chips
https://hatenachips.blog.fc2.com/blog-entry-377.html
 

投稿日時: 18/04/17 07:25:45
投稿者: simple

サイトの紹介、ありがとうございました。すばらしい。
やはりCurrency型を使われているのですね。
 
個人的にはなぜ、SingleからDoubleへの変換で、それほど大きい?誤差が入るのか
解明はできていないので残尿感(?失礼)はあるのですが、
数値の内部管理の問題ということで棚上げしておきたいと思います。
いずれにしてもCDbl(Timer)というのは根拠がないですし、
多数回の計算を求められるものでもないので速度の話は少し違うかも知れないと思いました。
以上です。

回答
投稿日時: 18/04/17 10:45:21
投稿者: たらのり

おはようございます
 
# ベクトル違いかもしれない & 釈迦に説法ですが…
 
小数部は、2進数でぴったり(※1)、精度の範囲(※2)で表現できない
数のとき、誤差が出る(出やすい)のだと思います。
 
※1) 2のべき乗の和で表現されるとき
※2) Single なら 10進 7桁、Double なら同 15桁 (多分)
 
以下は、2のべき乗の和で表現される値を使用した場合です:
 

Sub test()
    Dim t As Single
    Dim d As Double
    t = 0.96875
    d = t
    Debug.Print t  ' 出力  0.96875
    Debug.Print d  ' 出力  0.96875

    ' 2 ^ (-1) = 0.5
    ' 2 ^ (-2) = 0.25
    ' 2 ^ (-3) = 0.125
    ' 2 ^ (-4) = 0.0625
    ' 2 ^ (-5) = 0.03125
    '    TOTAL = 0.96875
End Sub

勘違いでしたらスミマセン…… m(_ _)m

回答
投稿日時: 18/04/17 17:49:30
投稿者: たらのり

ちょっと僕も疑問が涌いてきました……
 
 

    d = t       ' Double ← Single

 
の箇所は、右辺が近似値かどうかは分かりようがないので、
ビットパタンをそのまま複写すれば(IEEE754 のソレに従って)、
値は不変でもよさそうな気が。

投稿日時: 18/04/18 06:45:13
投稿者: simple

たらのりさん コメントありがとうございます。
ご指摘のとおり、SingleからDoubleへの型変換の方式が私にはよくわからないです、
ということでした。
もし、もしも、なにかご存じの方がおられましたら、ご一報くださるとうれしいです。
# 私が仕様を確認すればいいんでしょうけど、ちょっと時間が・・・。
# いや、意欲が・・・。というところです。

回答
投稿日時: 18/04/19 11:51:50
投稿者: hatena
投稿者のウェブサイトに移動

誤差がでるのは、たらのりさんが言われている、
 

引用:
小数部は、2進数でぴったり(※1)、精度の範囲(※2)で表現できない
数のとき、誤差が出る(出やすい)のだと思います。

が原因だと思います。
 
 
 72056.74      Single
 72056.7421875 Single to Double
 72056.74      Double

の場合だと、
72056.74 は、単精度の2進数では表現できないので、近い2進数に丸められる。
その丸められた数値を倍精度に変換するので、同じ値にはならない。
 
浮動小数点数内部表現シミュレーター - instant tools
http://tools.m-bsys.com/calculators/ieee754.php
 
上記のページを見つけたので、いろいろ確認してみました。
 
72056.74 を単精度に変換すると、
2進数表示では、
10001100101111000.1011110
10進指数数表示では、
7.2056734375e+4
 
このシミュレーターでは切り捨てで丸められているようなので、
切り上げて、
2進数 10001100101111000.1011111 を変換して、
10進指数表示にすると、
7.20567421875e+4
 
すなわち、
72056.7421875
になり上の Single to Double の変換結果と合致します。
 
これで、残尿感解消かな?

投稿日時: 18/04/19 23:43:13
投稿者: simple

ありがとうございます。
残尿感解消しましたww
 
>このシミュレーターでは切り捨てで丸められているようなので、
 
実際にメモリに保持されているビットを、下記のコードで確認してみました。
 
01000111 10001100 10111100 01011111
という32ビットの値で保持されているようです。
 
01000111 10001100 10111100 01011111
は、頭からそれぞれ符号部分(1ビット)指数部(8ビット)仮数部(23ビット)
として使われています。
 
なお、
・指数は実際の指数に127を足したものとします。
・また仮数部の整数部分の1は省略することになっています。
というのがIEEE754における、Single値のきまりのようです。
 
指数部(10001111)から127を引いた 16 が実際の指数です。
仮数部は、整数部分1を補足して、
1.00011001011110001011111
となります。
 
結局、
2の16乗×1.00011001011110001011111
つまり、
10001100101111000.1011111
となります。
小数部分だけ計算すると、0.7421875
となりますから、72056.74というSingle値は、
内部では実際は 72056.7421875 という値を
持っているのと同じことになるということかと思います。
皆さんのご指摘のとおりでした。
 
また、Single値をDblに代入したときは、仮数部の拡張された桁のところは
もちろん0が入りますね。
 
------------------------------
Option Explicit
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                               (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
 

Sub testS()
    Dim ary(0 To 3) As Byte
    Dim singleVal As Single
    Dim j As Long
    Dim k As Long
    Dim s As String

    singleVal = 72056.74
    CopyMemory ary(0), singleVal, 4
    For k = 3 To 0 Step -1
        For j = 7 To 0 Step -1
            If ary(k) And 2 ^ j Then
                s = s & "1"
            Else
                s = s & "0"
            End If
        Next j
        s = s & " "
    Next
    Debug.Print s
End Sub

# 昔、「小数点以下60桁表示? (Excel内部データ)」と言う名前のスレッドで
# 議論したことを使わしてもらっています。
# ぶらっくにゃおんさん、Abyssさんによります。
 
# なお、Double値も同様にビットの値を得ることができます。
# 符号(1)指数部(11ビット)仮数部(52ビット)
# 指数部は実際の指数に1023を足したもので管理されます。

回答
投稿日時: 18/04/20 00:37:40
投稿者: たらのり

こんばんは
  
あっ……
検証用のコードを書いて,もたもた説明を書いていたら,
simple さんがそっくりそのままww
  
せっかくなので(?)コードだけ置いておきますw
  
# 得られたビットパタンは,simple さんのそれと同一です多分
  

Type tByte4
    v(4 - 1)    As Byte
End Type

Type tByte8
    v(8 - 1)    As Byte
End Type

Type tSingle
    v           As Single
End Type

Type tDouble
    v           As Double
End Type

Sub test()
    Dim t As Single
    Dim d As Double
    t = 72056.74
    d = t
    Debug.Print t  ' 出力  72056.74
    Debug.Print d  ' 出力  72056.7421875

    Call DispAsBits_Single(t)
    Call DispAsBits_Double(d)
End Sub

Sub DispAsBits_Single(ByVal v As Single)

    Dim i As Long
    Dim f As tSingle
    Dim t As tByte4

    f.v = v
    LSet t = f

    For i = UBound(t.v) To LBound(t.v) Step -1
        Debug.Print Right$("00" & Hex(t.v(i)), 2) & " ";
    Next i
    Debug.Print

    For i = UBound(t.v) To LBound(t.v) Step -1
        Debug.Print ToBits(t.v(i)) & " ";
    Next i
    Debug.Print

End Sub

Sub DispAsBits_Double(ByVal v As Double)

    Dim i As Long
    Dim f As tDouble
    Dim t As tByte8

    f.v = v
    LSet t = f

    For i = UBound(t.v) To LBound(t.v) Step -1
        Debug.Print Right$("00" & Hex(t.v(i)), 2) & " ";
    Next i
    Debug.Print

    For i = UBound(t.v) To LBound(t.v) Step -1
        Debug.Print ToBits(t.v(i)) & " ";
    Next i
    Debug.Print

End Sub

Function ToBits(ByVal b As Byte) As String

    Dim i   As Long
    Dim x   As Long
    Dim s   As String
    
    x = &H80
    For i = 1 To 8
        s = s & IIf((CLng(b) And x), "1", "0")
        x = x \ 2
    Next i
    
    ToBits = s

End Function

 
■ 実行結果
 72056.74 
 72056.7421875 
47 8C BC 5F 
01000111 10001100 10111100 01011111 
40 F1 97 8B E0 00 00 00 
01000000 11110001 10010111 10001011 11100000 00000000 00000000 00000000 

投稿日時: 18/04/20 23:50:52
投稿者: simple

たらのりさん コメントありがとうございました。
エレガントですね。
LSetステートメントは使ったことがなかったので、勉強になります。
 
皆様、どうもありがとうございました。

投稿日時: 18/10/07 14:08:02
投稿者: simple

久しぶりに投稿します。
 
表示されたグラフに図形を書き込むという話題は、
こちらでは余り出て来ない印象があります。
最近、他の質問掲示板に「散布図に凸包を追加する」という話題が
載っていましたので、コードを作ってみました。
 
凸包というのは、複数のポイントに対し、これらを全て含む最小限の多角形をいいます。
二次元であれば、ポイントを輪ゴムで囲ったときにできる多角形をイメージして下さい。
何でも、散布図の値の散らばりの範囲を視覚化するために、
散布図に凸包表示をしたいとのことでした。
 
話は2つあって、
(1)凸包を求めること
(2)その多角形を散布図に描画すること
がテーマとなります。
 
(1)については計算幾何学というジャンルではプリミティブな話のようで、
1970年代に議論され、いくつかのアルゴリズムが知られているようです。
私は、A.M.Andrew のアルゴリズムというのを使ってみました。
 
(2)については、Chartオブジェクトは、Shapesオブジェクトをメンバに持てますので、
Chartオブジェクト内の散布図のPointの座標と共通の座標を指定して、
任意の図形を描くことができます。
(今まで実行したことがなかっただけで、意外に簡単だったことに驚きました。)
 
以下にコードを載せますが、その目的は、
・皆さんのなんらかの参考になれば幸いということと、
・実は、1つ教えて頂きたい点があるのです。
 
追加する多角形の線の色を、散布図のポイントの塗りつぶし色と同じものにしようと
しています。(系列が複数あるとき、色で系列を分別できるようにしたいわけです)。
ところが、散布図のポイントの塗りつぶし色は、常に0が返って来てしまい、
うまく取得できないのです。(コード中に★★★を付しています)
どなたかヒントをお持ちの方はご教示下さい。
 
 

Option Explicit

'散布図に凸包を追加するマクロ

'(1)作業用シートのシート名、(2)グラフの名前 の指定が必要

Const dummySheet As String = "dummy" '作業用シートの名前 ''■
Dim ws  As Worksheet
Dim mat As Variant
Dim mmax As Long

Sub test()
    Dim seriesNr    As Long
    Dim graph       As ChartObject
    Dim mychart     As Chart
    Dim convexHull  As Object
    
'    Set graph = Sheet1.ChartObjects("グラフ 1") ''■
'    Set mychart = graph.Chart
     Set mychart = ActiveChart ' としてもよい。

    For seriesNr = 1 To mychart.SeriesCollection.Count
        
        'mat: 昇順にソートされた (x値、Y値)からなる二次元配列
        mat = setMatrix(mychart, seriesNr)
        mmax = UBound(mat, 1)

        ' convexHull:凸包を構成する頂点のインデックスからなるArrayList
        Set convexHull = getConvexHull

        ' 凸包をグラフに書込む
        plot mychart, seriesNr, convexHull
    Next
    Set convexHull = Nothing
End Sub

'x,yを昇順にソート(3列目には元のデータの行番号を付与)
Function setMatrix(mychart As Chart, seriesNr As Long) As Variant
    Dim sr  As Series
    Dim cnt As Long
    Set sr = mychart.SeriesCollection(seriesNr)
    
    Set ws = Worksheets(dummySheet)    ' 作業用のダミーシート
    ws.UsedRange.ClearContents
    
    cnt = UBound(sr.XValues)
    ws.[A1].Resize(cnt, 1) = Application.Transpose(sr.XValues)
    ws.[B1].Resize(cnt, 1) = Application.Transpose(sr.Values)
    
    '元のindex値(連番)をC列に記入
    ws.[C1].Value = 1
    ws.[C1].AutoFill Destination:=ws.Range("C1").Resize(cnt, 1), Type:=xlFillSeries
    'X値,Y値をキーにして昇順にソート
    ws.[A1].CurrentRegion.Sort Key1:=ws.Range("A1"), Order1:=xlAscending, _
                               Key2:=ws.Range("B1"), Order2:=xlAscending, Header:=xlNo
    
    setMatrix = ws.[A1].Resize(cnt, 2).Value
End Function

Function getConvexHull() As Object
    'A.M.Andrew のアルゴリズムによる
    Dim upper As Object
    Dim lower As Object
    Dim cHull As Object
    Dim k     As Long

    Set upper = CreateObject("System.Collections.ArrayList")
    Set lower = CreateObject("System.Collections.ArrayList")
    Set cHull = CreateObject("System.Collections.ArrayList")

    '上半分から凸包を抽出
    upper.Add 1
    upper.Add 2
    For k = 3 To mmax
        upper.Add k
        Do
            If upper.Count < 3 Then Exit Do
            If check(upper, mat) Then Exit Do
            upper.removeAt (upper.Count - 1) - 1
        Loop
    Next

    '下半分から凸包を抽出
    lower.Add mmax
    lower.Add mmax - 1
    For k = mmax - 2 To 1 Step -1
        lower.Add k
        Do
            If lower.Count < 3 Then Exit Do
            If check(lower, mat) Then Exit Do
            lower.removeAt (lower.Count - 1) - 1
        Loop
    Next

    '上半分と下半分を重複を除いて連結
    cHull.addrange upper
    cHull.removeAt cHull.Count - 1
    cHull.addrange lower
    Set getConvexHull = cHull
 
    Set upper = Nothing
    Set lower = Nothing
    Set cHull = Nothing
End Function

'最後の3つのポイントを対象に右回りかどうかを判定(右回りならTrue)
Function check(ar As Object, mat As Variant) As Boolean
    Dim j&
    Dim vx#, vy#, wx#, wy#, cp#
    
    j = ar.Count - 1     'j は最後の値を指すindex。 ArrayListは0baseなので。
    vx = mat(ar(j - 1), 1) - mat(ar(j - 2), 1)  'ar(j - 1)は、ラストの1つ前のポイント
    vy = mat(ar(j - 1), 2) - mat(ar(j - 2), 2)
    wx = mat(ar(j), 1) - mat(ar(j - 2), 1)      'ar(j)  は、ラストのポイント
    wy = mat(ar(j), 2) - mat(ar(j - 2), 2)
    cp = vx * wy - vy * wx
    check = cp < -0.00000001        '負なら、j-2,j-1,jの指す点列は時計回り(右回り)
End Function

'凸包を構成する点を結んだ凸多角形をグラフに重ねて描画
Sub plot(mychart As Chart, seriesNr As Long, convexHull As Object)
    Dim p   As Variant
    Dim k   As Long
    Dim shp As Shape

    p = pos(mychart, seriesNr, convexHull, 1) '凸包の最初点のx座標とY座標を取得
    With mychart.Shapes.BuildFreeform(msoEditingAuto, p(0), p(1))
        For k = 2 To convexHull.Count
            p = pos(mychart, seriesNr, convexHull, k)
            .AddNodes msoSegmentLine, msoEditingAuto, p(0), p(1)
        Next
        Set shp = .ConvertToShape
    End With

    With shp.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorAccent5
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0.8
        .Transparency = 0.7
        .Solid
    End With

    With shp.Line
        .Weight = 0.5
        .DashStyle = msoLineSysDash
        'なぜか右辺が上手く取得できていない(原因不明)
        .ForeColor.RGB = mychart.SeriesCollection(seriesNr).Points(1).Format.Fill.ForeColor.RGB '★★★
        .Visible = msoTrue
    End With
End Sub

Function pos(mychart As Chart, seriesNr As Long, convexHull As Object, k As Long) As Variant
    Dim v As Long
    Dim p As Point
    
    v = ws.[C1].Offset(convexHull(k - 1) - 1).Value
    Set p = mychart.SeriesCollection(seriesNr).Points(v)
    pos = Array(p.Left, p.Top)
End Function

回答
投稿日時: 18/10/08 10:18:02
投稿者: マナ

>ところが、散布図のポイントの塗りつぶし色は、常に0が返って来てしまい、
 
棒グラフなら取得できるのですが、散布図はだめみたいです。バグ?
 
>追加する多角形の線の色を、散布図のポイントの塗りつぶし色と同じものにしようと
しています。
 
 
根本解決にはならないですが、
 
設定はできるので、逆に系列の色を揃えるか
 

mychart.SeriesCollection(1).Format.Fill.ForeColor.RGB = vbRed
.ForeColor.RGB = vbRed

 
あるいは、強引ですが、こんな感じでもできないことはないです。
コメントしておかないと、何やってるんでようというコードです。
 
Dim mycolor As Long

If mychart.SeriesCollection(1).MarkerBackgroundColor = -1 Then
    mychart.ChartType = xlColumnClustered
    mycolor = mychart.SeriesCollection(1).Format.Fill.ForeColor.RGB
    mychart.ChartType = xlXYScatter
Else
    mycolor = mychart.SeriesCollection(1).MarkerBackgroundColor
End If
.ForeColor.RGB = mycolor

投稿日時: 18/10/08 14:11:10
投稿者: simple

早速にコメントを頂き、ありがとうございます。
 
やはりバグですかね。
設定した直後に読み込むと0を返すので、"とりつく島がない"感じです。
 
なるほど、MarkerBackgroundColorですか。上手くいきますね。
ご指摘どうもありがとうございました。

トピックに返信