Results of 1 - 1 of about 37696 for IF (0.008 sec.)
- [[20191011155444]]
- #score: 1591
- @digest: 376fff614f5b33d7bf1c9b50a4e819c7
- @id: 81040
- @mdate: 2019-10-24T00:23:50Z
- @size: 90023
- @type: text/plain
- #keywords: 象物 (371073), 物a (165904), 物b (153868), 波形 (146420), phase1 (79599), mysary (67043), analysis (58035), のti (40007), power (30722), myskey (30305), time (27614), preserve (16828), 対象 (12782), lbound (12780), ubound (12478), ッチ (10708), マッ (10420), 大値 (9665), の0 (9554), redim (8821), 最大 (7145), 該当 (5859), variant (5499), 未満 (5277), - (5080), グル (4626), 、、 (4617), 55 (4589), function (4553), 表記 (4519), 51 (3747), サン (3722)
- 『VBAを用いた複雑なデータ比較（再投稿）
』（ぬまる猫） 以前、ご質問させて頂き多くの方々からご回答いただきました。 ありがとうございました。 今回はご指摘がありましたように、一度質問内容を整理して改めて投稿するようにとのことで、再度投稿させて頂きます。 （質問内容） 下記のようにデータがsheet1に並んでいます。 対象物a(A〜L列)とb(M〜X列)の組成をある分析機器で一定時間測定すると、それぞれ規則性のない特有の波形を測定できます。 成分の検出があれば山なりの波形となり、その検出時間(time)と波形の大きさ(power)が表記されます。 この波形には種類があり、50〜301の番号で表記されます。波形データと次の波形データの間は一定の間隔があります。 波形が全く測定されなかった場合は下記のように波形52の次に53、54のデータがなく、いきな波形55のデータが記載されます。 これらの波形番号ごとにtimeとpowerのデータが表記されています。time、powerの数は各波形で規則性なくばらばらです。 timeの並びは昇順です。各波形のtime、powerの数は最大で100です。 VBAで実施したいこと1 対象物aとbの各波形ごとに、time、powerを比較します。 ・対象物aのtimeで対象物bのtimeと近い値（差が0.05未満）となる似たtimeがある場合→対象物aの該当するpower/対象物bの該当するpower ・似たtimeがない場合→対象物aの該当するpower/1 結果から、値が5以上であれば、該当するtimeを該当するサンプル番号の下に表記します。 (Z列以降) 例えば、波形50では、対象物aのtime1.446は対象物bのtime1.445に近いのでそれぞれ同じ行の1655/2549<5→表記なし 一方で、対象物aのtime2.049は対象物bに近いtimeがないので同じ行の3945/1>5→2.049をAA列に表記します。 また、波形データがないものは波形番号も表記しません。 VBAで実施したいこと2 sheet2に、これら全ての波形のtimeを順に並べて、各timeに該当する波形番号を下記のように羅列したいです。 値が近いあるいは同じtime（差が0.05未満）の場合はその中で一番低い値を表記します。その際表記する波形番号は近い値すべてになり、昇順で表記します。 例えば、波形50の2.049と波形51の2.047と波形55の2.048は差が0.05未満なので、最小の値2.047のみ表記し、該当サンプル名には50、51、55が入ることになります。 また、timeの基準についてですが 50:1.45、51:1.41、52:1.49、53:1.50 の場合 →1.41 50 51 52 53 近接する全ての値を最小のtimeで表記します。（このパターンはおそらく起こりえないとは思いますが・・・） （その他の情報） ・トータルで使用する行は最大でも25000 ・-には規則性のない数値あるいは文字（今回の解析に必要ないデータ） ・出力場所はどこでも 以上1、2をVBAで実施する方法をご教授頂きたいと考えています。 よろしくお願い致します。 (sheet1) A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA AB AC 1 - - 50 51 52 55 2 - - - - 2.049 2.047 7.494 2.048 3 - - - - 2.646 6.963 7.667 2.174 4 - - - - 5.926 8.683 8.815 3.75 5 7.358 8.815 10.004 3.875 6 - - 7.925 8.997 4.75 7 - - - - 8.067 10.004 5.664 8 - 50 - 50 8.349 10.496 7.606 9 - Time - - - - power - - - - - - Time - - - - power - - - - - 12.46 9.556 10 - 1.446 - - - - 1655 - - - - - 1.445 - - - - 2549 - - - - 9.708 11 - 1.496 - - - - 2829 - - - - - 1.49 - - - - 3232 - - - - 9.836 12 - 2.049 - - - - 3945 - - - - - 2.161 - - - - 4017 - - - - 10.083 13 - 2.162 - - - - 2566 - - - - - 2.29 - - - - 1966 - - - - 12.028 14 - 2.553 - - - - 2093 - - - - - 2.554 - - - - 1095 - - - - 12.55 15 - 2.646 - - - - 1457 - - - - - 2.825 - - - - 1075 - - - - 12.75 16 - 2.831 - - - - 1527 - - - - - 2.997 - - - - 1486 - - - - 14.937 17 - 2.997 - - - - 2817 - - - - - 3.188 - - - - 1533 - - - - 15.333 18 - 3.493 - - - - 6342 - - - - - 3.492 - - - - 7995 - - - - 17.719 19 - 3.577 - - - - 16944 - - - - - 3.543 - - - - 5560 - - - - 20 - 3.942 - - - - 5348 - - - - - 3.576 - - - - 7614 - - - - 21 - 4.44 - - - - 16449 - - - - - 3.941 - - - - 4927 - - - - 22 - 4.913 - - - - 60583 - - - - - 4.438 - - - - 9986 - - - - 23 - 5.926 - - - - 1944 - - - - - 4.911 - - - - 32975 - - - - 24 - 7.071 - - - - 13315 - - - - - 7.069 - - - - 7152 - - - - 25 - 7.358 - - - - 1450 - - - - - 7.83 - - - - 5159 - - - - 26 - 7.833 - - - - 6631 - - - - - 8.146 - - - - 3739 - - - - 27 - 7.925 - - - - 1966 - - - - - 13.573 - - - - 2416 - - - - 28 - 8.067 - - - - 889 - - - - 29 - 8.149 - - - - 6882 - - - - - 28 30 - 8.349 - - - - 1786 - - - - - 51 31 - 13.575 - - - - 4774 - - - - - Time - - - - power - - - - - 32 - 1.485 - - - - 1251 - - - - 33 - - - 2.293 - - - - 1594 - - - - 34 - 51 - 2.553 - - - - 1412 - - - - 35 - Time - - - - power - - - - - - 2.642 - - - - 1390 - - - - 36 - 2.047 - - - - 2232 - - - - - 2.825 - - - - 1162 - - - - 37 - 2.292 - - - - 1027 - - - - - 2.997 - - - - 1348 - - - - 38 - 2.555 - - - - 1991 - - - - - 3.491 - - - - 10377 - - - - 39 - 2.645 - - - - 1293 - - - - - 3.542 - - - - 7825 - - - - 40 - 2.832 - - - - 2346 - - - - - 3.575 - - - - 8468 - - - - 41 - 2.998 - - - - 3183 - - - - - 3.941 - - - - 7928 - - - - 42 - 3.493 - - - - 8292 - - - - - 4.438 - - - - 14061 - - - - 43 - 3.578 - - - - 19379 - - - - - 4.911 - - - - 48583 - - - - 44 - 3.942 - - - - 8091 - - - - - 5.423 - - - - 2646 - - - - 45 - 4.44 - - - - 24090 - - - - - 5.934 - - - - 2015 - - - - 46 - 4.914 - - - - 90931 - - - - - 6.632 - - - - 1684 - - - - 47 - 5.425 - - - - 1786 - - - - - 7.069 - - - - 12838 - - - - 48 - 5.925 - - - - 5275 - - - - - 7.356 - - - - 4618 - - - - 49 - 6.634 - - - - 2610 - - - - - 7.492 - - - - 1716 - - - - 50 - 6.963 - - - - 1028 - - - - - 7.583 - - - - 1568 - - - - 51 - 7.071 - - - - 24454 - - - - - 7.783 - - - - 1680 - - - - 52 - 7.358 - - - - 6266 - - - - - 7.83 - - - - 21890 - - - - 53 - 7.494 - - - - 2461 - - - - - 8.068 - - - - 2616 - - - - 54 - 7.583 - - - - 1272 - - - - - 8.145 - - - - 13726 - - - - 55 - 7.783 - - - - 1620 - - - - - 8.345 - - - - 1458 - - - - 56 - 7.833 - - - - 30279 - - - - - 9.163 - - - - 950 - - - - 57 - 8.072 - - - - 2901 - - - - - 9.23 - - - - 954 - - - - 58 - 8.149 - - - - 25580 - - - - - 13.573 - - - - 13028 - - - - 59 - 8.349 - - - - 3353 - - - - - 18.578 - - - - 1139 - - - - 60 - 8.683 - - - - 995 - - - - 61 - 8.815 - - - - 1941 - - - - - - 62 - 8.997 - - - - 1401 - - - - - 52 63 - 9.234 - - - - 2199 - - - - - Time - - - - power - - - - - 64 - 10.004 - - - - 1144 - - - - - 1.473 - - - - 2764 - - - - 65 - 10.496 - - - - 956 - - - - - 1.592 - - - - 21849 - - - - 66 - 12.46 - - - - 1756 - - - - - 3.492 - - - - 2956 - - - - 67 - 13.575 - - - - 24713 - - - - - 3.542 - - - - 2065 - - - - 68 - 18.58 - - - - 1608 - - - - - 3.575 - - - - 2380 - - - - 69 - 3.941 - - - - 1661 - - - - 70 - - - 4.438 - - - - 4507 - - - - 71 - 52 - 4.911 - - - - 19282 - - - - 72 - Time - - - - power - - - - - - 7.069 - - - - 3113 - - - - 73 - 1.474 - - - - 4962 - - - - - 7.356 - - - - 2063 - - - - 74 - 1.593 - - - - 30328 - - - - - 7.831 - - - - 9818 - - - - 75 - 3.494 - - - - 2137 - - - - - 8.146 - - - - 6553 - - - - 76 - 3.577 - - - - 5413 - - - - - 13.573 - - - - 9794 - - - - 77 - 4.441 - - - - 7585 - - - - 78 - 4.913 - - - - 35629 - - - - - - 79 - 7.071 - - - - 5981 - - - - - 53 80 - 7.357 - - - - 2855 - - - - - Time - - - - power - - - - - 81 - 7.494 - - - - 1601 - - - - - 1.592 - - - - 102783 - - - - 82 - 7.667 - - - - 1451 - - - - - 2.293 - - - - 3654 - - - - 83 - 7.833 - - - - 13574 - - - - - 2.553 - - - - 3195 - - - - 84 - 8.149 - - - - 12739 - - - - - 2.646 - - - - 2151 - - - - 85 - 8.815 - - - - 2952 - - - - - 2.829 - - - - 5228 - - - - 86 - 10.004 - - - - 1773 - - - - - 3.001 - - - - 3301 - - - - 87 - 13.575 - - - - 18675 - - - - - 3.195 - - - - 1098 - - - - 88 - 3.491 - - - - 29975 - - - - 89 - - - 3.542 - - - - 18623 - - - - 90 - 55 - 3.575 - - - - 20295 - - - - 91 - Time - - - - power - - - - - - 3.942 - - - - 1405 - - - - 92 - 1.593 - - - - 145674 - - - - - 4.438 - - - - 35625 - - - - 93 - 2.048 - - - - 3764 - - - - - 4.911 - - - - 119243 - - - - 94 - 2.295 - - - - 2232 - - - - - 6.631 - - - - 2537 - - - - 95 - 2.554 - - - - 4906 - - - - - 6.958 - - - - 1555 - - - - 96 - 2.645 - - - - 2711 - - - - - 7.355 - - - - 10901 - - - - 97 - 2.832 - - - - 9662 - - - - - 7.497 - - - - 7452 - - - - 98 - 2.999 - - - - 5738 - - - - - 7.69 - - - - 1769 - - - - 99 - 3.494 - - - - 23450 - - - - - 7.783 - - - - 1132 - - - - 100 - 3.577 - - - - 46223 - - - - - 7.83 - - - - 33869 - - - - 101 - 3.792 - - - - 1997 - - - - - 8.067 - - - - 1200 - - - - 102 - 3.944 - - - - 3870 - - - - - 8.145 - - - - 47126 - - - - 103 - 4.44 - - - - 59625 - - - - - 8.811 - - - - 1617 - - - - 104 - 4.913 - - - - 227871 - - - - - 8.933 - - - - 1619 - - - - 105 - 5.208 - - - - 1181 - - - - - 8.998 - - - - 2058 - - - - 106 - 5.858 - - - - 966 - - - - - 9.163 - - - - 4235 - - - - 107 - 6.031 - - - - 1403 - - - - - 9.231 - - - - 4965 - - - - 108 - 6.075 - - - - 1884 - - - - - 12.458 - - - - 2715 - - - - 109 - 6.12 - - - - 1436 - - - - - 12.88 - - - - 1597 - - - - 110 - 6.633 - - - - 4386 - - - - - 13.133 - - - - 1077 - - - - 111 - 6.962 - - - - 2415 - - - - - 13.378 - - - - 1292 - - - - 112 - 7.357 - - - - 14799 - - - - - 13.573 - - - - 51749 - - - - 113 - 7.442 - - - - 1709 - - - - - 13.997 - - - - 2830 - - - - 114 - 7.497 - - - - 9878 - - - - - 18.579 - - - - 2309 - - - - 115 - 7.691 - - - - 2304 - - - - 116 - 7.783 - - - - 1136 - - - - 117 - 7.833 - - - - 46489 - - - - 118 - 8.067 - - - - 1240 - - - - 119 - 8.149 - - - - 89192 - - - - 120 - 8.217 - - - - 1888 - - - - 121 - 8.542 - - - - 1018 - - - - 122 - 8.814 - - - - 5007 - - - - 123 - 8.938 - - - - 2175 - - - - 124 - 9 - - - - 2084 - - - - 125 - 9.067 - - - - 1412 - - - - 126 - 9.165 - - - - 4917 - - - - 127 - 9.234 - - - - 9908 - - - - 128 - 9.835 - - - - 1129 - - - - 129 - 9.942 - - - - 2150 - - - - 130 - 10.005 - - - - 5085 - - - - 131 - 12.461 - - - - 4640 - - - - 132 - 13.005 - - - - 1602 - - - - 133 - 13.143 - - - - 2345 - - - - 134 - 13.378 - - - - 1753 - - - - 135 - 13.575 - - - - 97832 - - - - 136 - 14 - - - - 5428 - - - - 137 - 18.58 - - - - 3054 - - - - (sheet2) A B C D 1 2.047 50 51 55 2 2.174 55 3 2.646 50 4 3.75 55 5 3.875 55 6 4.75 55 7 5.664 55 8 5.926 50 9 6.963 51 10 7.358 50 11 7.494 52 12 7.606 55 13 7.667 52 14 7.925 50 15 8.067 50 16 8.349 50 17 8.683 51 18 8.815 51 52 19 8.997 51 20 9.556 55 52 21 9.708 55 22 9.836 55 23 10.004 51 24 10.083 55 25 10.496 51 26 12.028 55 27 12.46 51 28 12.55 55 29 12.75 55 30 14.937 55 31 15.333 55 32 17.719 55 ＜ 使用 Excel:Excel2013、使用 OS:Windows7 ＞ ---- 現在、VBAを自力で勉強中ですが、完全に初心者のため、デバックでエラーがでたところを確認しても、なぜ間違っているのか解読できずにいます。つまり、編集ができません。 来週、セミナーに参加して勉強する予定ですので、お手柔らかに教えていただけると幸いです。 （ぬまる猫） 2019/10/11(金) 16:31 ---- (1) まず、質問が2つありますが、最初の質問は解決済みではないんですか? 質問1は、前のスレッドでの質問とは別の質問ですか? （よく読んでなくて恐縮です。違うのなら、どう違うのかも説明ください。） 質問2についても、前のスレッドでコメントが寄せられています。 これについてのあなたのコメントは無いのですか? (2)質問1についての確認 ＞・対象物aのtimeで対象物bのtimeと近い値（差が0.05未満）となる似たtimeがある場合 とのこと。 対象物aのtimeが2.00 のとき、これと似たtimeが 1.96 と 2.03があったとき、 どちらの対象物bのpowerで判定するのですか? より近い方（上記なら2.03)ですか、それとも、ウチワで近いもの(1.96)ですか? それとも、こうしたことは起きえないのですか? (3)質問2についての確認 2.04 50 2.08 51 2.12 52 2.16 53 というデータがあった場合、結果はどうなりますか? 2.16 は 2.04 とは 0.12 乖離しているわけですが、 4つとも同じグループに入るということでよいのですね? (4)質問の最後に示された結果についてですが。 波形種類が 53 と 55が片方ずつありますが、意図したものですか? 2.174 というtimeがありますが、それはどこから来たものですか? （γ） 2019/10/11(金) 19:43 ---- これ、提示されたデータは、大本のデータに何らかの処理をした 処理後のものだろうと想像 波形っていってるけど全然波形じゃないし やってることが全然、理学的工学的じゃない たぶん波形っていってるのは、たぶん周波数で、 周波数毎の振幅が極大値をとった時間とスペクトル振幅とか ま、そんな感じか、それに似たことでしょう。 やっている仕事の領域がどんなものか知りませんが、 ちゃんとした本流のやり方があるはずなので、それを調べる方が早いと思います。 私は興味がないので、関わりません （´・ω・`） 2019/10/11(金) 20:24 ---- こんばんは! 第二ラウンドの始まりですね(^^; [[20190918140726]] リンクをはっておきます。 整形のところが変わるのかなと思いましたが、、基本的に変わりませんでした。 あと、55 がヒットしてますが、、相手がいないのでヒットしないでしょ??? これがヒットするとなると前レスの内容が根本的に変わってきますから、、どうなんでしょう?? まぁ、、おかげでヒットしなかった時の条件を見直すことが出来ましたけどね ご提示のサンプルデータでの解は↓の様になりました。。。 あと、、ほんとに忙しくてね。。レスポンスが悪くて申し訳ないですけど、、、まぁ、、気長に、、、 でも、、わちき的には、、ほぼ完成してると思いますよ。手を加えるところがないです。。。。 要は、、最初に提示されたレイアウトに持っていけば走るコードはあるので、、そこだけですよね??? 場合によってはFindとかもあるのかな?と考えましたが、、そのままコピペして走らせただけなので大丈夫だと思います(ちょっと自信なさげ(笑)） とろこで、、Rockしてますぅ??? AllRight!!!! 50 51 52 2.049 2.047 7.494 2.646 6.963 7.667 5.926 8.683 8.815 7.358 8.815 10.004 7.925 8.997 8.067 10.004 8.349 10.496 12.46 2.047 50 51 2.646 50 5.926 50 6.963 51 7.358 50 7.494 52 7.667 52 7.925 50 8.067 50 8.349 50 8.683 51 8.815 51 52 8.997 51 10.004 51 52 10.496 51 12.46 51 Option Explicit Sub てすと() Dim v As Variant Dim vv As Variant Dim x As Variant Dim y() As Variant Dim z() As Variant Dim w() As Variant Dim s() As Variant Dim ss() As Variant Dim t() As Variant Dim r As Range Dim rr As Range Dim u As Range Dim MyTblA As Areas Dim MyTblB As Areas Dim i As Long Dim j As Long Dim n As Long Dim k As Long Dim kk As Long Dim nn As Long Dim 最大値 As Long Dim 差 As Double Dim MyFlg As Boolean Dim MyFlgA As Boolean Dim 判定 As Boolean ReDim y(0) ReDim w(0) Application.ScreenUpdating = False If Not Evaluate("=ISREF(作業用!A1)") Then Sheets.Add.Name = "作業用" With Sheets("作業用") .Cells.Clear Sheets("Sheet1").UsedRange.Copy Destination:=.Range("A1") .Range("A:A,C:F,H:M,O:R,T:X").Delete Shift:=xlToLeft .Columns("C:C").Insert Shift:=xlToRight Set MyTblA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas Set MyTblB = .Range("D1", .Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas For Each r In MyTblA If u Is Nothing Then Set u = r(1, 1) Else Set u = Union(u, r(1, 1)) End If Next For Each rr In MyTblB If u Is Nothing Then Set u = r(1, 1) Else Set u = Union(u, rr(1, 1)) End If Next u.Clear Set MyTblA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas Set MyTblB = .Range("D1", .Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas For Each r In MyTblA v = r.Resize(, 2).Value For Each rr In MyTblB MyFlgA = False If r(1, 1) = rr(1, 1) Then k = 1 ReDim z(1 To k) vv = rr.Resize(, 2).Value For i = LBound(v, 1) + 2 To UBound(v, 1) x = Application.Match(v(i, 1), Application.Index(vv, 0, 1), 0) 'ちょうどの値がない場合近似値を探す If IsError(x) Then x = Application.Match(v(i, 1), Application.Index(vv, 0, 1), 1) 'エラーじゃなかったら If Not IsError(x) Then If x + 1 > UBound(vv) Then nn = UBound(vv) Else nn = x + 1 End If 'A列のtimeでC列のtimeと近い値（差が0.05未満）となる似たtimeがない場合 '一つ先も比較して両方なかったら近似値なしとする 差 = Application.Min(Abs(v(i, 1) - vv(x, 1)), Abs(v(i, 1) - vv(nn, 1))) If 差 > 0.05 Then '該当するB列のpower/1 If v(i, 2) / 1 >= 5 Then z(k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) End If Else 'A列のtimeでC列のtimeと近い値（差が0.05未満）となる似たtimeがある場合 '該当するB列のpower/該当するD列のpower '値が5以上であれば、該当するtimeを該当するサンプル番号の下に表記します。 'より小さい方を採用 'ここの判定が微妙 答えに合わせている If Abs(v(i, 1) - vv(x, 1)) <= Abs(v(i, 1) - vv(nn, 1)) Then If v(i, 2) / vv(x, 2) >= 5 Then z(k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) vv(x, 1) = Empty 判定 = True End If Else If v(i, 2) / vv(x, 2) >= 5 Then z(k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) vv(x, 1) = Empty 判定 = True End If End If End If End If Else 'ちょうどの場合 If v(i, 2) / vv(x, 2) >= 5 Then z(k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) vv(x, 1) = Empty 判定 = True End If End If '成功したら再編して再セット If 判定 Then 再編 vv rr.CurrentRegion.Clear rr.Resize(UBound(vv, 1), UBound(vv, 2)).Value = vv 判定 = False End If Next y(n) = z n = n + 1 ReDim Preserve y(n) Exit For End If Next 'ヒットしたら If (k > 1) * (UBound(y) > UBound(w)) Then w(kk) = r(1, 1) kk = kk + 1 ReDim Preserve w(kk) Else If UBound(y) > UBound(w) Then n = n - 1 ReDim Preserve y(n) End If End If Next k = 1 w = Application.Transpose(w) ReDim s(1 To 2, 1 To k) For n = LBound(y) To UBound(y) - 1 If 最大値 < UBound(y(n), 1) Then 最大値 = UBound(y(n), 1) ReDim Preserve w(1 To UBound(w, 1), 1 To 最大値 + 1) For j = LBound(y(n), 1) To UBound(y(n), 1) w(n + 1, j + 1) = y(n)(j) s(1, k) = y(n)(j) s(2, k) = w(n + 1, 1) k = k + 1 ReDim Preserve s(1 To 2, 1 To k) Next k = k - 1 ReDim Preserve s(1 To 2, 1 To k) Next k = k - 1 ReDim Preserve s(1 To 2, 1 To k) s = Application.Transpose(s) QuickSort s, LBound(s, 1), UBound(s, 1), 1 ReDim Preserve s(LBound(s, 1) To UBound(s, 1), LBound(s, 2) To UBound(s, 2) + 1) For i = LBound(s, 1) + 1 To UBound(s, 1) If Abs(s(i - 1, 1) - s(i, 1)) > 0.05 Then s(i, UBound(s, 2)) = 1 Else s(i, UBound(s, 2)) = Empty End If Next k = 0 n = 0 最大値 = 0 ReDim z(0) ReDim t(0) z(n) = s(1, 1) t(k) = s(1, 2) For i = LBound(s, 1) + 1 To UBound(s, 1) If s(i, 3) = "" Then k = k + 1 ReDim Preserve t(k) t(k) = s(i, 2) ReDim Preserve y(n) y(n) = t If 最大値 < k Then 最大値 = k Else k = 0 n = n + 1 ReDim Preserve t(k) t(k) = s(i, 2) ReDim Preserve y(n) y(n) = t ReDim Preserve z(n) z(n) = s(i, 1) End If Next ReDim ss(1 To n + 1, 1 To 最大値 + 2) For i = LBound(y) To UBound(y) ss(i + 1, 1) = z(i) If UBound(y(i)) > 0 Then QuickSort y(i), LBound(y(i)), UBound(y(i)) For j = LBound(y(i)) To UBound(y(i)) ss(i + 1, j + 2) = y(i)(j) Next Next Application.DisplayAlerts = False .Delete Application.DisplayAlerts = False End With With Sheets("Sheet2") .Cells.Clear With .Range("A1") .Resize(UBound(ss, 1), UBound(ss, 2)).Value = ss .Offset(, .CurrentRegion.Columns.Count + 2).Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w) End With End With Application.ScreenUpdating = True Set MyTblA = Nothing Set MyTblB = Nothing Set u = Nothing Erase v, vv, y, z, w, s, ss, t End Sub Private Sub QuickSort(MySAry As Variant, ByVal MySLeft As Long, ByVal MySRight As Long, Optional ByVal MySKey As Long) Dim MySMid As Double Dim i As Long, j As Long, n As Long Dim MySLBound As Long, MySUBound As Long Dim MyStmp As String If MySKey > 0 Then MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) ¥ 2, MySKey) Else MySMid = MySAry((MySLeft + MySRight) ¥ 2) End If i = MySLeft j = MySRight Do If MySKey > 0 Then Do While MySAry(i, MySKey) < MySMid i = i + 1 Loop Do While MySAry(j, MySKey) > MySMid j = j - 1 Loop If i >= j Then Exit Do For n = MySLBound To MySUBound MyStmp = MySAry(i, n) MySAry(i, n) = MySAry(j, n) MySAry(j, n) = MyStmp Next Else Do While MySAry(i) < MySMid i = i + 1 Loop Do While MySAry(j) > MySMid j = j - 1 Loop If i >= j Then Exit Do MyStmp = MySAry(i) MySAry(i) = MySAry(j) MySAry(j) = MyStmp End If i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySLeft, i - 1, MySKey If MySRight > j + 1 Then QuickSort MySAry, j + 1, MySRight, MySKey End Sub Sub 再編(MyA As Variant) Dim MyB As Variant Dim i As Long Dim j As Long Dim k As Long ReDim MyB(LBound(MyA, 1) To UBound(MyA, 1), LBound(MyA, 2) To UBound(MyA, 2)) For i = LBound(MyA, 1) To UBound(MyA, 1) If MyA(i, 1) <> "" Then k = k + 1 For j = LBound(MyA, 2) To UBound(MyA, 2) MyB(k, j) = MyA(i, j) Next End If Next MyB = Application.Transpose(MyB) ReDim Preserve MyB(LBound(MyA, 2) To UBound(MyA, 2), LBound(MyA, 1) To k) MyA = Application.Transpose(MyB) End Sub （SoulMan） 2019/10/11(金) 21:03 ---- 追加でコメントだけ、、 ↓これは、、 >現在、VBAを自力で勉強中ですが、 >完全に初心者のため、デバックでエラーがでたところを確認しても、 >なぜ間違っているのか解読できずにいます。つまり、編集ができません。 ある意味当然だと思いますよ? 別人が書いたコードなのですから、、、そりゃわかりませんよ(笑) ここは、考え方を変えて、、、ずばり、、今は、、 無理・・・なんですよ(ちょっときついかもですけど、、） でも、そういうのもなんだと思いますよ 所詮は、、他人が書いたコードなのですよ。。。 大切なことは、、背伸びせずに身の丈にあったコードから地道に始めることだと思いますよ。 セミナーもいいでしょうけど、、私が、、こういうExcelを始めた当時は、、当然、、こんな掲示板もなければ、、 セミナーもない。。Excel97 SuperMasterって本を買ってきましてね。。。今でも、、、ありますよ。 時々みてます。。 その本の中に解説付きのサンプルコードがあるんですけど、、それを繰り返し繰り返し読んで理解してましたね。 やり方は、、それぞれなので、、決して押し付けてるんじゃないですからね。。誤解されない様に。。。 特に今回私が書いたコードは、、配列 というものを使ったコードなのですが、、この配列というのは イメージがすごく大事で書いた本人でも数日後に見直すと、、「なんじゃこりゃ???」となるものなのですよ。 それより以前にVBEの画面が、、 コードを書くところ イミデイエイトウィンドウ ローカルウィンドウ この三つの構成になっていることの方が重要です。 アドバイス出来るとしたらコードの中にコメントを入れるのもいいでしょうね。。 その都度解説するのですね。。それをPrintOutして繰り返し読むとかね。。。 まぁ、、この辺のお話になると、、そのセミナーの方がいいかもしれませんね。。。 まぁ、、ローマは一日にしてならず です。 でも、、為せば成るっていうことわざもありますしね。。。 ご健闘をお祈り致します。m(__)m （SoulMan） 2019/10/11(金) 22:44 ---- 上手く伝えられないので、、ちょっと追加。。。 誤解しないで聞いて欲しんですけど、、、 私は今回、提示したコードを苦労して書いてないのです。 というと、、自慢に聞こえるかもしれませんが、、、 コードを書くとういうことと、、 構成、、イメージ、、、ストーリーを考える 想像する というのは違うのです。 コードを書くということは、、そんなに難しくないのです。 私のコードをよくよく見ると、、、基本的に if ○○ Then Else Endif この繰り返しなのですね。。。 なので、、先ずは、、日本語でこのストーリーを書ける様になることが重要なのです。 どういうアプローチから入るか? この入り方を間違えると、、わけわかめ???無茶苦茶になります。(←よくやってます(笑)） 支離滅裂になって来ましたので、、、もう寝ますね。。。 おやすみなさいzzzzzzzzzzzzzzzzzzz （SoulMan） 2019/10/11(金) 23:27 ---- ＞（γ） さん （1） ・最初の質問は半分解決しました。 ・以前のスレッドは上記の質問を関数で実施する方法を問うもでした。しかし、関数では処理が重すぎて、途中からVBAに質問内容を切り替えたため、新たに整理して投稿させて頂きました。 ・以前のスレッドに対するコメントも投稿しております。 [[20190918140726]] （2） 対象物aのtimeが1.00、1.04、1.08でこれと似た対象物bのtimeが1.00、1.05の場合、 それぞれ一番近い値を優先的にとります。aの1.00はbの1.00、aの1.04はbの1.05、aの1.08はbの1.05をとりたいところですが、既にとられているのでこの場合該当なしでpowerが1となります。 （3） 2.04 50 51 52 53 となります。 （4） 意図したものです。波形がすべて検出されるわけではないことを示す具体例として挙げさせて頂きました。 申し訳ありません、値を間違えておりました。訂正致します。 ＞（´・ω・`） さん 大本のデータを数値化したものです。 情報の開示が十分にできず、説明が分かりづらくなって申し訳ありません。 本流のやり方はメーカーが数百万で販売しているもので、オープンになっておりません。 購入せずに何とかする方法がないか模索しており、みなさんのお力をお借りさせて頂いた次第です。 ご興味がないなか、貴重なレスポンスを頂きありがとうございます。 ＞（SoulMan）さん いつもありがとうございます。 55までの記載ですが、実際は301まで続いております。 相方は書き忘れておりましたので修正します。 （ぬまる猫） 2019/10/12(土) 00:04 ---- (sheet1) A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA AB AC 1 - - 50 51 52 55 2 - - - - 2.049 2.047 7.494 2.048 3 - - - - 2.646 6.963 7.667 3.792 4 - - - - 5.926 8.683 8.815 5.208 5 7.358 8.815 10.004 6.12 6 - - 7.925 8.997 7.357 7 - - - - 8.067 10.004 7.442 8 - 50 - 50 8.349 10.496 7.783 9 - Time - - - - power - - - - - - Time - - - - power - - - - - 12.46 8.814 10 - 1.446 - - - - 1655 - - - - - 1.445 - - - - 2549 - - - - 8.938 11 - 1.496 - - - - 2829 - - - - - 1.49 - - - - 3232 - - - - 9.835 12 - 2.049 - - - - 3945 - - - - - 2.161 - - - - 4017 - - - - 14 13 - 2.162 - - - - 2566 - - - - - 2.29 - - - - 1966 - - - - 14 - 2.553 - - - - 2093 - - - - - 2.554 - - - - 1095 - - - - 15 - 2.646 - - - - 1457 - - - - - 2.825 - - - - 1075 - - - - 16 - 2.831 - - - - 1527 - - - - - 2.997 - - - - 1486 - - - - 17 - 2.997 - - - - 2817 - - - - - 3.188 - - - - 1533 - - - - 18 - 3.493 - - - - 6342 - - - - - 3.492 - - - - 7995 - - - - 19 - 3.577 - - - - 16944 - - - - - 3.543 - - - - 5560 - - - - 20 - 3.942 - - - - 5348 - - - - - 3.576 - - - - 7614 - - - - 21 - 4.44 - - - - 16449 - - - - - 3.941 - - - - 4927 - - - - 22 - 4.913 - - - - 60583 - - - - - 4.438 - - - - 9986 - - - - 23 - 5.926 - - - - 1944 - - - - - 4.911 - - - - 32975 - - - - 24 - 7.071 - - - - 13315 - - - - - 7.069 - - - - 7152 - - - - 25 - 7.358 - - - - 1450 - - - - - 7.83 - - - - 5159 - - - - 26 - 7.833 - - - - 6631 - - - - - 8.146 - - - - 3739 - - - - 27 - 7.925 - - - - 1966 - - - - - 13.573 - - - - 2416 - - - - 28 - 8.067 - - - - 889 - - - - 29 - 8.149 - - - - 6882 - - - - - 28 30 - 8.349 - - - - 1786 - - - - - 51 31 - 13.575 - - - - 4774 - - - - - Time - - - - power - - - - - 32 - 1.485 - - - - 1251 - - - - 33 - - - 2.293 - - - - 1594 - - - - 34 - 51 - 2.553 - - - - 1412 - - - - 35 - Time - - - - power - - - - - - 2.642 - - - - 1390 - - - - 36 - 2.047 - - - - 2232 - - - - - 2.825 - - - - 1162 - - - - 37 - 2.292 - - - - 1027 - - - - - 2.997 - - - - 1348 - - - - 38 - 2.555 - - - - 1991 - - - - - 3.491 - - - - 10377 - - - - 39 - 2.645 - - - - 1293 - - - - - 3.542 - - - - 7825 - - - - 40 - 2.832 - - - - 2346 - - - - - 3.575 - - - - 8468 - - - - 41 - 2.998 - - - - 3183 - - - - - 3.941 - - - - 7928 - - - - 42 - 3.493 - - - - 8292 - - - - - 4.438 - - - - 14061 - - - - 43 - 3.578 - - - - 19379 - - - - - 4.911 - - - - 48583 - - - - 44 - 3.942 - - - - 8091 - - - - - 5.423 - - - - 2646 - - - - 45 - 4.44 - - - - 24090 - - - - - 5.934 - - - - 2015 - - - - 46 - 4.914 - - - - 90931 - - - - - 6.632 - - - - 1684 - - - - 47 - 5.425 - - - - 1786 - - - - - 7.069 - - - - 12838 - - - - 48 - 5.925 - - - - 5275 - - - - - 7.356 - - - - 4618 - - - - 49 - 6.634 - - - - 2610 - - - - - 7.492 - - - - 1716 - - - - 50 - 6.963 - - - - 1028 - - - - - 7.583 - - - - 1568 - - - - 51 - 7.071 - - - - 24454 - - - - - 7.783 - - - - 1680 - - - - 52 - 7.358 - - - - 6266 - - - - - 7.83 - - - - 21890 - - - - 53 - 7.494 - - - - 2461 - - - - - 8.068 - - - - 2616 - - - - 54 - 7.583 - - - - 1272 - - - - - 8.145 - - - - 13726 - - - - 55 - 7.783 - - - - 1620 - - - - - 8.345 - - - - 1458 - - - - 56 - 7.833 - - - - 30279 - - - - - 9.163 - - - - 950 - - - - 57 - 8.072 - - - - 2901 - - - - - 9.23 - - - - 954 - - - - 58 - 8.149 - - - - 25580 - - - - - 13.573 - - - - 13028 - - - - 59 - 8.349 - - - - 3353 - - - - - 18.578 - - - - 1139 - - - - 60 - 8.683 - - - - 995 - - - - 61 - 8.815 - - - - 1941 - - - - - - 62 - 8.997 - - - - 1401 - - - - - 52 63 - 9.234 - - - - 2199 - - - - - Time - - - - power - - - - - 64 - 10.004 - - - - 1144 - - - - - 1.473 - - - - 2764 - - - - 65 - 10.496 - - - - 956 - - - - - 1.592 - - - - 21849 - - - - 66 - 12.46 - - - - 1756 - - - - - 3.492 - - - - 2956 - - - - 67 - 13.575 - - - - 24713 - - - - - 3.542 - - - - 2065 - - - - 68 - 18.58 - - - - 1608 - - - - - 3.575 - - - - 2380 - - - - 69 - 3.941 - - - - 1661 - - - - 70 - - - 4.438 - - - - 4507 - - - - 71 - 52 - 4.911 - - - - 19282 - - - - 72 - Time - - - - power - - - - - - 7.069 - - - - 3113 - - - - 73 - 1.474 - - - - 4962 - - - - - 7.356 - - - - 2063 - - - - 74 - 1.593 - - - - 30328 - - - - - 7.831 - - - - 9818 - - - - 75 - 3.494 - - - - 2137 - - - - - 8.146 - - - - 6553 - - - - 76 - 3.577 - - - - 5413 - - - - - 13.573 - - - - 9794 - - - - 77 - 4.441 - - - - 7585 - - - - 78 - 4.913 - - - - 35629 - - - - - - 79 - 7.071 - - - - 5981 - - - - - 53 80 - 7.357 - - - - 2855 - - - - - Time - - - - power - - - - - 81 - 7.494 - - - - 1601 - - - - - 1.592 - - - - 102783 - - - - 82 - 7.667 - - - - 1451 - - - - - 2.293 - - - - 3654 - - - - 83 - 7.833 - - - - 13574 - - - - - 2.553 - - - - 3195 - - - - 84 - 8.149 - - - - 12739 - - - - - 2.646 - - - - 2151 - - - - 85 - 8.815 - - - - 2952 - - - - - 2.829 - - - - 5228 - - - - 86 - 10.004 - - - - 1773 - - - - - 3.001 - - - - 3301 - - - - 87 - 13.575 - - - - 18675 - - - - - 3.195 - - - - 1098 - - - - 88 - 3.491 - - - - 29975 - - - - 89 - - - 3.542 - - - - 18623 - - - - 90 - 55 - 3.575 - - - - 20295 - - - - 91 - Time - - - - power - - - - - - 3.942 - - - - 1405 - - - - 92 - 1.593 - - - - 145674 - - - - - 4.438 - - - - 35625 - - - - 93 - 2.048 - - - - 3764 - - - - - 4.911 - - - - 119243 - - - - 94 - 2.295 - - - - 2232 - - - - - 6.631 - - - - 2537 - - - - 95 - 2.554 - - - - 4906 - - - - - 6.958 - - - - 1555 - - - - 96 - 2.645 - - - - 2711 - - - - - 7.355 - - - - 10901 - - - - 97 - 2.832 - - - - 9662 - - - - - 7.497 - - - - 7452 - - - - 98 - 2.999 - - - - 5738 - - - - - 7.69 - - - - 1769 - - - - 99 - 3.494 - - - - 23450 - - - - - 7.783 - - - - 1132 - - - - 100 - 3.577 - - - - 46223 - - - - - 7.83 - - - - 33869 - - - - 101 - 3.792 - - - - 1997 - - - - - 8.067 - - - - 1200 - - - - 102 - 3.944 - - - - 3870 - - - - - 8.145 - - - - 47126 - - - - 103 - 4.44 - - - - 59625 - - - - - 8.811 - - - - 1617 - - - - 104 - 4.913 - - - - 227871 - - - - - 8.933 - - - - 1619 - - - - 105 - 5.208 - - - - 1181 - - - - - 8.998 - - - - 2058 - - - - 106 - 5.858 - - - - 966 - - - - - 9.163 - - - - 4235 - - - - 107 - 6.031 - - - - 1403 - - - - - 9.231 - - - - 4965 - - - - 108 - 6.075 - - - - 1884 - - - - - 12.458 - - - - 2715 - - - - 109 - 6.12 - - - - 1436 - - - - - 12.88 - - - - 1597 - - - - 110 - 6.633 - - - - 4386 - - - - - 13.133 - - - - 1077 - - - - 111 - 6.962 - - - - 2415 - - - - - 13.378 - - - - 1292 - - - - 112 - 7.357 - - - - 14799 - - - - - 13.573 - - - - 51749 - - - - 113 - 7.442 - - - - 1709 - - - - - 13.997 - - - - 2830 - - - - 114 - 7.497 - - - - 9878 - - - - - 18.579 - - - - 2309 - - - - 115 - 7.691 - - - - 2304 - - - - 116 - 7.783 - - - - 1136 - - - - - - 117 - 7.833 - - - - 46489 - - - - - 53 118 - 8.067 - - - - 1240 - - - - - Time - - - - power - - - - - 119 - 8.149 - - - - 89192 - - - - - 1.592 - - - - 102783 - - - - 120 - 8.217 - - - - 1888 - - - - - 2.293 - - - - 3654 - - - - 121 - 8.542 - - - - 1018 - - - - - 2.553 - - - - 3195 - - - - 122 - 8.814 - - - - 5007 - - - - - 2.646 - - - - 2151 - - - - 123 - 8.938 - - - - 2175 - - - - - 2.829 - - - - 5228 - - - - 124 - 9 - - - - 2084 - - - - - 3.001 - - - - 3301 - - - - 125 - 9.067 - - - - 1412 - - - - - 3.195 - - - - 1098 - - - - 126 - 9.165 - - - - 4917 - - - - - 3.491 - - - - 29975 - - - - 127 - 9.234 - - - - 9908 - - - - - 3.542 - - - - 18623 - - - - 128 - 9.835 - - - - 1129 - - - - - 3.575 - - - - 20295 - - - - 129 - 9.942 - - - - 2150 - - - - - 3.942 - - - - 1405 - - - - 130 - 10.005 - - - - 5085 - - - - - 4.438 - - - - 35625 - - - - 131 - 12.461 - - - - 4640 - - - - - 4.911 - - - - 119243 - - - - 132 - 13.005 - - - - 1602 - - - - - 6.631 - - - - 2537 - - - - 133 - 13.143 - - - - 2345 - - - - - 6.958 - - - - 1555 - - - - 134 - 13.378 - - - - 1753 - - - - - 7.355 - - - - 10901 - - - - 135 - 13.575 - - - - 97832 - - - - - 7.497 - - - - 7452 - - - - 136 - 14 - - - - 5428 - - - - - 7.69 - - - - 1769 - - - - 137 - 18.58 - - - - 3054 - - - - - 7.783 - - - - 1132 - - - - 138 - 7.83 - - - - 33869 - - - - - 8.067 - - - - 1200 - - - - - 8.145 - - - - 47126 - - - - - 8.811 - - - - 1617 - - - - - 8.933 - - - - 1619 - - - - - 8.998 - - - - 2058 - - - - - 9.163 - - - - 4235 - - - - - 9.231 - - - - 4965 - - - - - 12.458 - - - - 2715 - - - - - 12.88 - - - - 1597 - - - - - 13.133 - - - - 1077 - - - - - 13.378 - - - - 1292 - - - - - 13.573 - - - - 51749 - - - - - 13.997 - - - - 2830 - - - - - 18.579 - - - - 2309 - - - - - 20 - 54 - Time - - - - power - - - - - - 1.473 - - - - 4180 - - - - - 1.592 - - - - 21389 - - - - - 3.491 - - - - 16000 - - - - - 3.542 - - - - 6565 - - - - - 3.575 - - - - 4888 - - - - - 4.438 - - - - 25387 - - - - - 4.911 - - - - 34848 - - - - - 6.072 - - - - 1442 - - - - - 7.323 - - - - 2874 - - - - - 7.358 - - - - 1658 - - - - - 7.689 - - - - 2394 - - - - - 7.83 - - - - 3481 - - - - - 7.952 - - - - 4854 - - - - - 8.144 - - - - 3533 - - - - - 8.414 - - - - 2935 - - - - - 8.808 - - - - 961 - - - - - 8.934 - - - - 3115 - - - - - 9.231 - - - - 11644 - - - - - 10.672 - - - - 1373 - - - - - 13.573 - - - - 7113 - - - - - 77 - 55 - Time - - - - power - - - - - - 1.473 - - - - 1569 - - - - - 1.592 - - - - 188445 - - - - - 1.833 - - - - 1717 - - - - - 1.875 - - - - 15573 - - - - - 2.293 - - - - 16879 - - - - - 2.554 - - - - 2475 - - - - - 2.644 - - - - 5379 - - - - - 2.829 - - - - 7044 - - - - - 2.9 - - - - 2004 - - - - - 2.997 - - - - 6661 - - - - - 3.311 - - - - 1858 - - - - - 3.373 - - - - 4458 - - - - - 3.491 - - - - 792164 - - - - - 3.539 - - - - 253788 - - - - - 3.943 - - - - 67031 - - - - - 4.117 - - - - 9413 - - - - - 4.158 - - - - 8112 - - - - - 4.25 - - - - 4922 - - - - - 4.29 - - - - 4936 - - - - - 4.333 - - - - 3322 - - - - - 4.438 - - - - 161460 - - - - - 4.667 - - - - 667 - - - - - 4.911 - - - - 315302 - - - - - 5.282 - - - - 1897 - - - - - 5.542 - - - - 5722 - - - - - 5.86 - - - - 2767 - - - - - 5.966 - - - - 7244 - - - - - 6.07 - - - - 13409 - - - - - 6.63 - - - - 1564 - - - - - 6.96 - - - - 8966 - - - - - 7.008 - - - - 5776 - - - - - 7.15 - - - - 1381 - - - - - 7.227 - - - - 4524 - - - - - 7.325 - - - - 11276 - - - - - 7.39 - - - - 16304 - - - - - 7.516 - - - - 7516 - - - - - 7.695 - - - - 10536 - - - - - 7.831 - - - - 23237 - - - - - 8.1 - - - - 3192 - - - - - 8.145 - - - - 17314 - - - - - 8.215 - - - - 5972 - - - - - 8.325 - - - - 4425 - - - - - 8.414 - - - - 3843 - - - - - 8.542 - - - - 4291 - - - - - 9.008 - - - - 1850 - - - - - 9.07 - - - - 4667 - - - - - 9.163 - - - - 21608 - - - - - 9.231 - - - - 43985 - - - - - 9.617 - - - - 3165 - - - - - 9.944 - - - - 2528 - - - - - 10.033 - - - - 2335 - - - - - 10.183 - - - - 994 - - - - - 10.342 - - - - 1920 - - - - - 10.59 - - - - 3027 - - - - - 10.672 - - - - 6918 - - - - - 10.949 - - - - 2867 - - - - - 11.267 - - - - 879 - - - - - 11.331 - - - - 3438 - - - - - 11.6 - - - - 1386 - - - - - 11.926 - - - - 1487 - - - - - 12.197 - - - - 2388 - - - - - 12.458 - - - - 2661 - - - - - 12.609 - - - - 10824 - - - - - 12.88 - - - - 19856 - - - - - 13.002 - - - - 1928 - - - - - 13.133 - - - - 1195 - - - - - 13.177 - - - - 2401 - - - - - 13.293 - - - - 1397 - - - - - 13.378 - - - - 1837 - - - - - 13.573 - - - - 74526 - - - - - 13.832 - - - - 2285 - - - - - 13.891 - - - - 1766 - - - - - 13.997 - - - - 3026 - - - - - 14.432 - - - - 1533 - - - - - 14.742 - - - - 1833 - - - - - 15.935 - - - - 1498 - - - - - 18.578 - - - - 10834 - - - - (sheet2) A B C D 1 2.047 50 51 55 2 2.646 50 3 3.792 55 4 5.208 55 5 5.926 50 6 6.12 55 7 6.963 51 8 7.357 50 55 9 7.442 55 10 7.494 52 11 7.667 52 12 7.783 55 13 7.925 50 14 8.067 50 15 8.349 50 16 8.683 51 17 8.814 51 52 55 18 8.938 55 19 8.997 51 20 9.835 55 21 10.004 51 52 22 10.496 51 23 12.46 51 24 14 55 （ぬまる猫） 2019/10/12(土) 00:05 ---- ウィーーーん、、がちゃ、、、ぴーっっ、、チェックOK おはようございます。。。(お前は、、ウルトラマンか(^^;） 常連の皆様におかれましては早朝よりお騒がせしております。。。 解決に向けて鋭意努力しておりますので今しばらくお待ちください。。。 ところで、、55 の 14 が引っ掛かりませんね。。。でも、、当初のコードでやっても引っ掛からないので 何かの間違いであって欲しい(希望的観測） 出力先のデータも増減するでしょうから、、塊の二つとなりに出力する様にしました。。。 上のコードは差し替えておきました。。。 では、、では、、、 2.047 50 51 55 2.646 50 3.792 55 5.208 55 5.926 50 6.963 51 7.358 50 7.442 55 7.494 52 7.667 52 7.925 50 8.067 50 8.149 55 8.349 50 8.683 51 8.815 51 52 55 8.938 55 8.997 51 9.835 55 10.004 51 52 10.496 51 12.46 51 50 51 52 55 2.049 2.047 7.494 2.048 2.646 6.963 7.667 3.792 5.926 8.683 8.815 5.208 7.358 8.815 10.004 7.442 7.925 8.997 8.149 8.067 10.004 8.814 8.349 10.496 8.938 12.46 9.835 （SoulMan） 2019/10/12(土) 07:31 ---- 何回もすみません。 50 の 7.357 と 55 の 14 がヒットしてませんね(^^; それはそうと、、集計するところをちょっと見直しました。。。 上のコードは差し替えています。。。 今のところの解は↓です。 2.047 50 51 55 2.646 50 3.792 55 5.208 55 5.926 50 6.963 51 7.358 50 7.442 55 7.494 52 7.667 52 7.925 50 8.067 50 8.149 55 8.349 50 8.683 51 8.814 51 52 55 8.938 55 8.997 51 9.835 55 10.004 51 52 10.496 51 12.46 51 50 51 52 55 2.049 2.047 7.494 2.048 2.646 6.963 7.667 3.792 5.926 8.683 8.815 5.208 7.358 8.815 10.004 7.442 7.925 8.997 8.149 8.067 10.004 8.814 8.349 10.496 8.938 12.46 9.835 （SoulMan） 2019/10/12(土) 09:08 ---- 質問への回答ありがとうございました。 (2)への回答はやや不十分に感じました。 55 の 6.12 というのは少しレベルの違う話かなと感じました。 たぶん、「一度マッチしたものは、二度マッチに使うことができない」 とでもいったルールが、明示されずに適用されているんでしょう。 もし、そうであれば、そこはお二方のロジック上では対応されていないので、 対応が必要かもしれませんね。 （γ） 2019/10/12(土) 11:19 ---- 以下は、ケース55の一部です。 Time power Time power 5.858 966 3.943 67031 6.031 1403 4.117 9413 6.075 1884 4.158 8112 6.12 1436 4.25 4922 6.633 4386 4.29 4936 6.962 2415 4.333 3322 7.357 14799 4.438 161460 7.442 1709 4.667 667 7.497 9878 4.911 315302 7.691 2304 5.282 1897 7.783 1136 5.542 5722 7.833 46489 5.86 2767 8.067 1240 5.966 7244 8.149 89192 6.07 13409 8.217 1888 6.63 1564 8.542 1018 6.96 8966 8.814 5007 7.008 5776 8.938 2175 7.15 1381 あなたは 6.12を対象として挙げたが、この関係で以下のように考えたが、妥当だろうか。 ・6.031 の0.05未満の最も近いtime(以下、most nearestと書く）は 6.07。 ・6.075 の most nearestは 6.07 であるが、既に使っているので、使えない。 次の time 6.63 は 0.05以上乖離しているので、結局マッチせず。 power条件で該当するので、6.075 はリストに載ってくるのではないか。 ・6.12 の most nearestは 6.07 （演算誤差か、差は 0.049999999となり0.5未満） 6.07は既に使っているので、次の6.63が候補だが、 これも0.05以上乖離しているので、結局マッチせず。 power条件で該当するので、6.12 もリストに載ってくるのではないか。 6.12だけが対象となる根拠を教えて頂きたい。 このあたりのロジックを正確に提示するのは、質問者さんの仕事と思うがどうか。 （γ） 2019/10/12(土) 22:24 ---- 回答を待っていましたが、もう終了でしたか。 課題1のコードを作ってみましたので、参考までに。 ・データは "Data"シートにおいて下さい。 ・結果を "Phase1"に書き込みます。（なければ、自動作成します） 結果は、こうなりました。（データの配置等は、2019/10/12(土) 00:05のものを使用） 50 51 52 55 2.049 2.047 7.494 2.048 2.646 6.963 7.667 3.792 5.926 8.683 8.815 5.208 7.358 8.815 10.004 6.075 7.925 8.997 6.12 8.067 10.004 7.442 8.349 10.496 7.833 12.46 8.149 8.814 8.938 9.835 大枠はkazuoさんのコードを参考にさせてもらいました。 mostNearestは新規に追加しています。 Sub testPhase1() '1サンプル当りのデータ最大数(仮置き数値。場合によって拡大必要） Const 最大数 As Long = 100 Dim wsd As Worksheet Dim ws As Worksheet Dim x1 Dim x2 Dim t2 As Range Dim r As Range, a As Range, b As Range Dim acount&, i&, j&, ichi&, k&, n&, mn& Dim former& Dim diff As Double Dim mat Dim ans Set wsd = Worksheets("Data") Set r = wsd.Range("B7", wsd.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants) ReDim mat(1 To 最大数, 1 To r.Areas.Count) '(1) Outlierを検出する（結果は配列matに保持) For Each a In r.Areas acount = acount + 1 x1 = a.Resize(, 6).Value 'Debug.Print "--------------------------"; x1(2, 1) For Each b In wsd.Range("N7", wsd.Range("N" & Rows.Count).End(xlUp)) _ .SpecialCells(xlCellTypeConstants).Areas x2 = b.Resize(, 6).Value If x1(2, 1) = x2(2, 1) Then Set t2 = b.Columns(1) Set t2 = Intersect(t2, t2.Offset(3)) '最初の3行は捨てる k = 1: mat(k, acount) = x1(2, 1): k = k + 1 'caseNo j = 0 For n = 4 To UBound(x1, 1) '■t2の範囲を限定したところを対象に、最近接値を検索する ans = mostNearest(x1(n, 1), t2, j) mn = ans(0) diff = ans(1) 'Debug.Print n; mn; diff If Abs(diff) < 0.05 Then j = ans(0) ' 0.05未満の近さのときだけ、マッチしたものとし、 '以後の検索ではマッチさせない End If ' power 条件で判定 If Abs(diff) < 0.05 Then If x1(n, 6) / x2(mn + 3, 6) >= 5 Then ' mat(k, acount) = x1(n, 1): k = k + 1 Debug.Print "== 1 == "; x1(n, 1) End If Else If x1(n, 6) / 1 >= 5 Then mat(k, acount) = x1(n, 1): k = k + 1 Debug.Print "== 2 == "; x1(n, 1) End If End If Next n Exit For 'bに同じNoのものがあっても相手をしない End If Next b Next a ' (2) 配列 mat を"Phase1"シートに書き出す---------------------------- On Error Resume Next Set ws = Worksheets("Phase1") If Err.Number > 0 Then Set ws = Worksheets.Add(before:=Worksheets(1)) ws.Name = "Phase1" Else ws.Cells.ClearContents End If On Error GoTo 0 ws.Range("A1").Resize(UBound(mat, 1), UBound(mat, 2)).Value = mat End Sub Function mostNearest(a As Variant, rng As Range, ofst As Long) As Variant Dim r As Range Dim m As Variant Dim v1#, v2# Dim diff# Dim mn As Long Set r = Intersect(rng, rng.Offset(ofst)) 'マッチ済みのものを排除する m = Application.Match(a, r, 1) 'aを超えない最大値がなければ、先頭が最近接値の候補 If IsError(m) Then mn = ofst + 1 diff = a - r(1, 1) 'aを超えない最大値があれば、それと次の近い方が最近接値 Else v1 = r(m, 1) v2 = r(m + 1, 1) If Abs(a - v1) < Abs(a - v2) Then mn = ofst + m diff = a - v1 Else mn = ofst + m + 1 diff = a - v2 End If End If mostNearest = Array(mn, diff) End Function 余り詳細に検証していないので、落とし穴があるかもしれません。 （γ） 2019/10/14(月) 07:31 ---- 続いて課題2についても、ワークシート上で操作するコードを書いてみました。 ・"Phase1"を元に、 ・結果を "Analysis"に書き込みます。（なければ、自動作成します） 【結果】 A B C D E F G H 2.047 51 1 2.047 51 55 50 2.048 55 2.646 50 2.049 50 3.792 55 2.646 50 1 5.208 55 3.792 55 1 5.926 50 5.208 55 1 6.075 55 55 5.926 50 1 6.963 51 6.075 55 1 7.358 50 6.12 55 7.442 55 6.963 51 1 7.494 52 7.358 50 1 7.667 52 7.442 55 1 7.833 55 7.494 52 1 7.925 50 7.667 52 1 8.067 50 7.833 55 1 8.149 55 7.925 50 1 8.349 50 8.067 50 1 8.683 51 8.149 55 1 8.814 55 51 52 8.349 50 1 8.938 55 8.683 51 1 8.997 51 8.814 55 1 9.835 55 8.815 51 10.004 51 52 8.815 52 10.496 51 8.938 55 1 12.46 51 8.997 51 1 9.835 55 1 10.004 51 1 10.004 52 10.496 51 1 12.46 51 1 1列にしたデータも参考に左側に残しています。 なお、FGH列はあえてソートしていません。時刻順に対応しているからです。 （どうしてもというなら、ソートして下さい。マクロ記録+αで対応可能です） ------------------------------------------------------------------ Option Explicit Dim ws1 As Worksheet, ws2 As Worksheet Sub testPhase2() '"Phase1"のデータをもとに、課題2の結果を"Analysis"シートに出力する Set ws1 = Worksheets("Phase1") On Error Resume Next Set ws2 = Worksheets("Analysis") If Err.Number > 0 Then Set ws2 = Worksheets.Add(before:=Worksheets(1)) ws2.Name = "Analysis" Else ws2.Cells.ClearContents End If On Error GoTo 0 '(1)"Phase1"シートから"Analysis"シートにデータを転記 Call データの転記 '(2)A,B 列を A列をキーに昇順にソート Call ソート '(3)前の時刻と0.05乖離しているかどうかでグループ内かを判定 Call time判定 '(4)結果を表にまとめる Call グルーピング End Sub Function データの転記() ' n 列のデータを ' 2列 A列(time) B列(波形種類)で、縦に並べる Dim p As Long Dim c As Variant Dim rng As Range Dim r As Range Dim caseNo As Long Dim numOfRows As Long With ws1 'Worksheets("Phase1") p = 1 For c = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column caseNo = .Cells(1, c).Value Set rng = .Range(.Cells(2, c), .Cells(.Rows.Count, c).End(xlUp)) numOfRows = rng.Rows.Count rng.Copy ws2.Cells(p, 1) 'ws2 は"Analysis"シート ws2.Cells(p, 2).Resize(numOfRows, 1).Value = caseNo p = p + numOfRows Next End With End Function Function ソート() 'A列(time)を最優先キーとして、昇順に並べ替える With ws2.Sort .SortFields.Clear .SortFields.Add Key:=ws2.Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange ws2.Range("A1").CurrentRegion .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Function Function time判定() '前の時刻と 0.05超で乖離していたら、3列目にflagとして1を建てる。 Dim k As Long With ws2 .Cells(1, 3).Value = 1 For k = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row If .Cells(k, 1).Value - .Cells(k - 1, 1).Value > 0.05 Then .Cells(k, 3).Value = 1 End If Next End With End Function Function グルーピング() '3列目が Blankの場合は、同一グループであるとして、 '1グループを1行に、波形種類をならべる。 Dim k As Long Dim colToWrite As Long Dim p As Long p = 0 With ws2 For k = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row If .Cells(k, 3).Value = 1 Then p = p + 1 colToWrite = 6 .Cells(p, 5) = .Cells(k, 1) .Cells(p, colToWrite) = .Cells(k, 2) Else '同じグループ内 colToWrite = colToWrite + 1 .Cells(p, colToWrite) = .Cells(k, 2) End If Next End With End Function （γ） 2019/10/14(月) 07:34 ---- おはようございます。。 ちょっと分からなくなってきましたね。。 私からすると↓これは、、初耳でした(私が見落としていただけかもしれません。。） >対象物aのtimeが1.00、1.04、1.08でこれと似た対象物bのtimeが1.00、1.05の場合、 >それぞれ一番近い値を優先的にとります。 >aの1.00はbの1.00、aの1.04はbの1.05、aの1.08はbの1.05をとりたいところですが、 >既にとられているのでこの場合該当なしでpowerが1となります。 まぁ、、それはともかく一度ヒットしたものは、、消して再編するコードを追加しました。。 追加するところが微妙なので間違っているかもですけど、、解は変わりませんでした。。 明日からまた、、登校できないと思いますので、、ここまでの私見をまとめてみます。 まず、、このトピの始まりは、、数式では重いので、、マクロで、、みたいな始まりだったと思います。 で、条件は、、シンプルで二つか三つ、、、ストーリーは割と簡単、、、 途中、、おかしいなとおもうところもありましたが、、取り敢えず、、解に合わせる。。。 次に、、総チェックの話が出てそれは、、本トピと違うでしょ?という流れで別トピへ。。。ですよね? で、トピ主さんは、しきりにグループの数を気にされていましたが、、 こういうトピの場合、その数は特段 問題ではなくて、、むしろしっかりとしたサンプルさえあれば、、 後は、、ループするだけなので 時間はかかるでしょうけど、、一つでいいとおもいます。 それよりも問題なのは、、いくつかデータを増やしていくうちに こんなパターンもありました。。 こんなケースもありました。。 と言われる方が問題で、、はっきり言って「しらんがな!」の世界だと思います。。。 まぁ、、そういう最初の詰めをはっきりしないままコード書いてしまった私が悪いんでしょうけど。。。。 結局、、この手のトピはトピ主さんが全てでトピ主さんが「白」と言えば白 「黒」と言えば黒なんですよね。 ここまで来たら、、大筋のコードはあると思いますので、、ご自身の納得のいくようなコードに編集されるしかないのではないでしょうか? と思います。。。です。。。 あっ、上のコードは差し替えておきました。 では、、では、、←また、、がないね(^^; ※誤字、脱字、乱文を修正。。。ほかにもあったらごめんなさいm(__)m （SoulMan） 2019/10/14(月) 09:10 ---- やはりエッジケース?についての検証が不十分でした。 mostNearestを以下のものに差し替えてください。 Function mostNearest(a As Variant, rng As Range, ofst As Long) As Variant Dim r As Range Dim m As Variant Dim v1#, v2# Dim diff# Dim mn As Long Set r = Intersect(rng, rng.Offset(ofst)) 'マッチ済みのものを排除する If r Is Nothing Then mostNearest = Array(0, 10000) Else m = Application.Match(a, r, 1) 'aを超えない最大値がなければ、先頭が最近接値 If IsError(m) Then mn = ofst + 1 diff = a - r(1, 1) 'aを超えない最大値があれば、それと次の近い方が最近接値 Else v1 = r(m, 1) v2 = r(m + 1, 1) If Abs(a - v1) < Abs(a - v2) Then mn = ofst + m diff = a - v1 Else mn = ofst + m + 1 diff = a - v2 End If End If mostNearest = Array(mn, diff) End If End Function ところで、質問者さんは質問するだけでバイバイなんでしょうか? 普通はありえませんね。 （γ） 2019/10/15(火) 12:50 ---- ＞ところで、質問者さんは質問するだけでバイバイなんでしょうか? ＞普通はありえませんね。 ＞（γ） 2019/10/15(火) 12:50 世間は昨日まで3連休。 あるいは、もしかしたら台風の被災で、それどころではないのかもしれない。 そうは思いませんか? （笑） 2019/10/15(火) 13:10 ---- なるほど。休日は質問していても見ないんですかね。 とりあえずのコメントくらい期待したのが間違いでしたか。 待ちましょう。 （γ） 2019/10/15(火) 13:28 ---- 失礼いたしました。思いっきり被害を受けて、避難なりなんなりで ご連絡返せておりませんでした。 もうしばらくお時間いただけると助かります。 （ぬまる猫） 2019/10/15(火) 13:46 ---- みなさん、ご連絡遅くなり申し訳ありません。 ＞（γ）さん Analysisで何度実行しても固まってしまいます。すいません。 ＞（SoulMan）さん わたしの定義が定まっていないというのはおっしゃる通りです。 定義をもう一度考えなおします。 今しばらくお時間ください。 （ぬまる猫） 2019/10/15(火) 14:07 ---- 被害を受けているなら、こんなこと、いや失礼、は放置して、 生活を元に戻すことに集中されたらどうですか? いうまでもないことですけど。 （γ） 2019/10/15(火) 15:49 ---- ＞（γ）さん 片付けは終わって午後から出社しておりますので、もう大丈夫です。 一部定義を変更致しました。最終の定義としたいです。 再度こちらでご検討お願いできませんでしょうか。 VBAで実施したいこと1 対象物aとbの各波形ごとに、time、powerを比較します。 ・対象物aのtimeで対象物bのtimeと近い値（差が0.03以下）となる似たtimeがある場合→対象物aの該当するpower/対象物bの該当するpower 一つの対象物aに対して0.03以下の差の対象物bが2つあった場合→差が異なれば差の少ないtimeを使用、差が同じであれば小さいほうのtimeを使用 昇順にtimeを比較していき、一度マッチしたtimeは、二度マッチに使うことができません。 以下の場合、対象物aの0.03と対象物bの0.05がマッチ 対象物aの0.06は該当timeなし（0.05はすでに使用しているので使えない） 対象物aの0.10と対象物bの0.08、0.12が差が0.03以下で、差が同じなので小さいほうの0.08をマッチ となります。 （例） 対象物a 対象物b time time 0.03 0.05 0.06 0.1 0.08 0.12 （ぬまる猫） 2019/10/15(火) 16:26 ---- 私は外にいて環境にアクセスできません。 なお、過去にいくつか確認の質問をしています。 前提数値は違っても根は同じはずです。 時間がとれれば、回答をしてください。 （γ） 2019/10/15(火) 17:48 ---- だっだだだ、、だ、、うぃぃぃぃん きゃぁ〜〜〜〜SoulMan!ぱんつはいてぇ〜〜〜(お前は、、ターミネーターか?） すみません。。前振りに無理がありましたm(__)m (そんなんどないでもええから、早よ!回答せんかえ!!はい、わかりました。。すみませんm(__)m） えええっ、、と、、、最初から書き直せば、もう少しこましなコードになると思いますが、、いかせん。。時間がないもんで、、現状のコードを変更です。 あってるといいんですけどねぇ。。。。(長くなっちゃいましたね。。いつものことですけど。。。） 被害にあわれたのでしたら、、お見舞い申し上げます。。。 私は、、いつもここにいますから。。生きていればの話ですけど。。。。どうぞ、、お気をつけてください。 一日も早い回復をお祈りしています。。。。では、、では、、、 2.047 50 51 55 2.646 50 3.577 55 3.792 55 5.208 55 5.926 50 6.031 55 6.12 55 6.963 51 7.357 50 55 7.442 55 7.494 52 7.667 52 7.783 55 7.925 50 8.067 50 55 8.149 55 8.349 50 8.683 51 8.814 51 52 55 8.938 55 8.997 51 9.835 55 10.004 51 52 10.496 51 12.46 51 50 51 52 55 2.049 2.047 7.494 2.048 2.646 6.963 7.667 3.577 5.926 8.683 8.815 3.792 7.358 8.815 10.004 5.208 7.925 8.997 6.031 8.067 10.004 6.12 8.349 10.496 7.357 12.46 7.442 7.783 8.067 8.149 8.814 8.938 9.835 Option Explicit '対象物aとbの各波形ごとに、time、powerを比較します。 '・対象物aのtimeで対象物bのtimeと近い値（差が0.03以下）となる似たtimeがある場合→ '対象物aの該当するpower/対象物bの該当するpower '一つの対象物aに対して0.03以下の差の対象物bが2つあった場合→ '差が異なれば差の少ないtimeを使用、差が同じであれば小さいほうのtimeを使用 ' 昇順にtimeを比較していき、一度マッチしたtimeは、二度マッチに使うことができません。 '以下の場合、対象物aの0.03と対象物bの0.05がマッチ '対象物aの0.06は該当timeなし（0.05はすでに使用しているので使えない） ' 対象物aの0.10と対象物bの0.08、0.12が差が0.03以下で、差が同じなので小さいほうの0.08をマッチ ' となります。 Sub てすと() Dim v As Variant Dim vv As Variant Dim x As Variant Dim y() As Variant Dim z() As Variant Dim w() As Variant Dim s() As Variant Dim ss() As Variant Dim t() As Variant Dim r As Range Dim rr As Range Dim u As Range Dim MyTblA As Areas Dim MyTblB As Areas Dim i As Long Dim j As Long Dim n As Long Dim k As Long Dim kk As Long Dim nn As Long Dim sp As Long Dim tp As Long Dim ni As Long Dim 最大値 As Long Dim 差 As Double Dim MyFlg As Boolean Dim MyFlgA As Boolean ReDim y(0) ReDim w(0) Application.ScreenUpdating = False If Not Evaluate("=ISREF(作業用!A1)") Then Sheets.Add.Name = "作業用" With Sheets("作業用") .Cells.Clear Sheets("Sheet1").UsedRange.Copy Destination:=.Range("A1") .Range("A:A,C:F,H:M,O:R,T:X").Delete Shift:=xlToLeft .Columns("C:C").Insert Shift:=xlToRight Set MyTblA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas Set MyTblB = .Range("D1", .Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas For Each r In MyTblA If u Is Nothing Then Set u = r(1, 1) Else Set u = Union(u, r(1, 1)) End If Next For Each rr In MyTblB If u Is Nothing Then Set u = r(1, 1) Else Set u = Union(u, rr(1, 1)) End If Next u.Clear Set MyTblA = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas Set MyTblB = .Range("D1", .Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas For Each r In MyTblA v = r.Resize(, 2).Value For Each rr In MyTblB MyFlgA = False If r(1, 1) = rr(1, 1) Then k = 1 ReDim z(1 To k) vv = rr.Resize(, 2).Value sp = LBound(vv, 1) + 2 For i = LBound(v, 1) + 2 To UBound(v, 1) '近似値を探す x = Application.Match(v(i, 1), Application.Index(vv, 0, 1), 1) 'ヒットしたら If Not IsError(x) Then If x + 1 > UBound(vv) Then nn = UBound(vv) Else nn = x + 1 End If 差 = Application.Min(Abs(v(i, 1) - vv(x, 1)), Abs(v(i, 1) - vv(nn, 1))) '一つ先も比較して0.03より大きい場合は近似値なし If 差 > 0.03 Then '該当するB列のpower/1 If v(i, 2) / 1 >= 5 Then z(k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) End If Else '・対象物aのtimeで対象物bのtimeと近い値（差が0.03以下）となる似たtimeがある場合→ '対象物aの該当するpower/対象物bの該当するpower '一つの対象物aに対して0.03以下の差の対象物bが2つあった場合→ '差が異なれば差の少ないtimeを使用、差が同じであれば小さいほうのtimeを使用 ' 昇順にtimeを比較していき、一度マッチしたtimeは、二度マッチに使うことができません。 If Abs(v(i, 1) - vv(x, 1)) <= Abs(v(i, 1) - vv(nn, 1)) Then If v(i, 2) / vv(x, 2) >= 5 Then z(k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) tp = x For ni = sp To tp vv(ni, 1) = Empty Next sp = tp End If Else If v(i, 2) / vv(nn, 2) >= 5 Then z(k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) tp = nn For ni = sp To tp vv(ni, 1) = Empty Next sp = tp End If End If End If Else 'ヒットしなかった場合は無条件で先頭を採用 If tp + 1 > UBound(vv, 1) Then tp = UBound(vv, 1) Else tp = tp + 1 End If If v(i, 2) / vv(tp, 2) >= 5 Then z(k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) For ni = sp To tp vv(ni, 1) = Empty Next sp = tp End If End If If sp > UBound(vv, 1) Then Exit For Next y(n) = z n = n + 1 ReDim Preserve y(n) Exit For End If Next 'ヒットしたら If (k > 1) * (UBound(y) > UBound(w)) Then w(kk) = r(1, 1) kk = kk + 1 ReDim Preserve w(kk) Else If UBound(y) > UBound(w) Then n = n - 1 ReDim Preserve y(n) End If End If Next k = 1 w = Application.Transpose(w) ReDim s(1 To 2, 1 To k) For n = LBound(y) To UBound(y) - 1 If 最大値 < UBound(y(n), 1) Then 最大値 = UBound(y(n), 1) ReDim Preserve w(1 To UBound(w, 1), 1 To 最大値 + 1) For j = LBound(y(n), 1) To UBound(y(n), 1) w(n + 1, j + 1) = y(n)(j) s(1, k) = y(n)(j) s(2, k) = w(n + 1, 1) k = k + 1 ReDim Preserve s(1 To 2, 1 To k) Next k = k - 1 ReDim Preserve s(1 To 2, 1 To k) Next k = k - 1 ReDim Preserve s(1 To 2, 1 To k) s = Application.Transpose(s) QuickSort s, LBound(s, 1), UBound(s, 1), 1 ReDim Preserve s(LBound(s, 1) To UBound(s, 1), LBound(s, 2) To UBound(s, 2) + 1) For i = LBound(s, 1) + 1 To UBound(s, 1) If Abs(s(i - 1, 1) - s(i, 1)) > 0.05 Then s(i, UBound(s, 2)) = 1 Else s(i, UBound(s, 2)) = Empty End If Next k = 0 n = 0 最大値 = 0 ReDim z(0) ReDim t(0) z(n) = s(1, 1) t(k) = s(1, 2) For i = LBound(s, 1) + 1 To UBound(s, 1) If s(i, 3) = "" Then k = k + 1 ReDim Preserve t(k) t(k) = s(i, 2) ReDim Preserve y(n) y(n) = t If 最大値 < k Then 最大値 = k Else k = 0 n = n + 1 ReDim Preserve t(k) t(k) = s(i, 2) ReDim Preserve y(n) y(n) = t ReDim Preserve z(n) z(n) = s(i, 1) End If Next ReDim ss(1 To n + 1, 1 To 最大値 + 2) For i = LBound(y) To UBound(y) ss(i + 1, 1) = z(i) If UBound(y(i)) > 0 Then QuickSort y(i), LBound(y(i)), UBound(y(i)) For j = LBound(y(i)) To UBound(y(i)) ss(i + 1, j + 2) = y(i)(j) Next Next Application.DisplayAlerts = False .Delete Application.DisplayAlerts = False End With With Sheets("Sheet2") .Cells.Clear With .Range("A1") .Resize(UBound(ss, 1), UBound(ss, 2)).Value = ss .Offset(, .CurrentRegion.Columns.Count + 2).Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w) End With End With Application.ScreenUpdating = True Set MyTblA = Nothing Set MyTblB = Nothing Set u = Nothing Erase v, vv, y, z, w, s, ss, t End Sub Private Sub QuickSort(MySAry As Variant, ByVal MySLeft As Long, ByVal MySRight As Long, Optional ByVal MySKey As Long) Dim MySMid As Double Dim i As Long, j As Long, n As Long Dim MySLBound As Long, MySUBound As Long Dim MyStmp As String If MySKey > 0 Then MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) ¥ 2, MySKey) Else MySMid = MySAry((MySLeft + MySRight) ¥ 2) End If i = MySLeft j = MySRight Do If MySKey > 0 Then Do While MySAry(i, MySKey) < MySMid i = i + 1 Loop Do While MySAry(j, MySKey) > MySMid j = j - 1 Loop If i >= j Then Exit Do For n = MySLBound To MySUBound MyStmp = MySAry(i, n) MySAry(i, n) = MySAry(j, n) MySAry(j, n) = MyStmp Next Else Do While MySAry(i) < MySMid i = i + 1 Loop Do While MySAry(j) > MySMid j = j - 1 Loop If i >= j Then Exit Do MyStmp = MySAry(i) MySAry(i) = MySAry(j) MySAry(j) = MyStmp End If i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySLeft, i - 1, MySKey If MySRight > j + 1 Then QuickSort MySAry, j + 1, MySRight, MySKey End Sub すみません。解はかわりませんでしたが、間違いを修正しました。m(__)m （SoulMan） 2019/10/15(火) 22:09 ---- あっ、総チェックのところの差が0.05のままですね もうパソコン閉じちゃったので明日にでも直します 改造すると前後の繋がりや変数の指定がわからなくなるので コードは一気に書きあげないといけませんね では、おやすみなさい💤 （SoulMan） 2019/10/15(火) 23:26 ---- 大変ですね。被害もお仕事も本当に大丈夫なのでしょうか。 ＞対象物aの0.06は該当timeなし（0.05はすでに使用しているので使えない） このデータ比較の意義がわかりません。 対象物aの0.06は対象物bの0.08がマッチでは無いのでしょうか。 もし、対象物aの0.03と対象物bの0.05とがそれぞれ観測されなかった場合は、 対象物aの0.10は該当timeなし（0.08はすでに使用しているので使えない） なのでしょうか? また、対象物bのサンプル番号が有っても対象物aのサンプル番号が無い場合は表記しないは解りましたが、 対象物aのサンプル番号が有っても対象物bのサンプル番号が無い場合はどうするのでしょうか? （kazuo） 2019/10/16(水) 07:41 ---- ＞（γ）さん 波形55の場合のご質問に対して ・6.031 の0.05未満の最も近いtime(以下、most nearestと書く）は 6.07。 →差が0.03以下の場合を採用するように変更しましたので、6.031に該当なし ・6.075 の most nearestは 6.07 であるが、既に使っているので、使えない。 次の time 6.63 は 0.05以上乖離しているので、結局マッチせず。 power条件で該当するので、6.075 はリストに載ってくるのではないか。 →上記より、6.075には6.07を採用 ・6.12 の most nearestは 6.07 （演算誤差か、差は 0.049999999となり0.5未満） 6.07は既に使っているので、次の6.63が候補だが、 これも0.05以上乖離しているので、結局マッチせず。 power条件で該当するので、6.12 もリストに載ってくるのではないか。 →6.12は該当なし となります。 >（kazuo）さん ご心配ありがとうございます。何とかやっています。 それよりも例が間違っていました。すいません。訂正致します。 以下の場合、対象物aの0.03と対象物bの0.05がマッチ 対象物aの0.06は該当timeなし（0.05はすでに使用しているので使えない） 対象物aの0.12と対象物bの0.10、0.14が差が0.03以下で、差が同じなので小さいほうの0.10をマッチ となります。 対象物a 対象物b time time 0.03 0.05 0.06 0.12 0.1 0.14 ちなみに間違えていた例題だと 対象物aの0.03と対象物bの0.05がマッチ 対象物aの0.06は対象物bの0.08とマッチ（0.05はすでに使用しているので使えない） 対象物aの0.1と対象物bの0.12がマッチ（0.08はすでに使用しているので使えない） また、対象物aのサンプル番号が有っても対象物bのサンプル番号が無い場合は対象物aのサンプルデータを採用し、似たtimeがない場合→対象物aの該当するpower/1 で処理したいです。 ＞（SoulMan）さん 後から、何度も改定させてしまい申し訳ありません。 私が気が付いていない部分で、まだ定義不足なところがあるかもしれません。 （ぬまる猫） 2019/10/16(水) 10:52 ---- ●回答ありがとうございます。 6.12が0.05未満マッチなし、だけでなく6.075も同様ではないですか? というのが質問の趣旨でした。 判断基準を0.03に変えた結果を尋ねているのではありません。 ＞前提数値は違っても根は同じはずです。 というのはそう言う意味でした。 もともとは、私が、 | 55 の 6.12 というのは少しレベルの違う話かなと感じました。 | たぶん、「一度マッチしたものは、二度マッチに使うことができない」 | とでもいったルールが、明示されずに適用されているんでしょう。 と今までにない論点に気づいたのも、あなたの例示結果の分析からです。 ですから、まだ別の観点からのルールが抜けていないのか確認したかったのです。 なぜ6.12だけがが0.05未満マッチなしとなるのか、根拠が知りたかったのです。 間違いなら間違いでいいのです。 ところが、基準は0.03に変わりました云々は、拍子抜けです。 ● | Analysisで何度実行しても固まってしまいます。 とのことでしたが、こちらでは再現しません。 25000件程度で実行しても、4秒程度で終了します。 その部分で配列で計算せずに、あえてワークシート上で計算させたのは、 あなたが今後検証や編集をしていく上でそのほうが扱いやすいだろうと考えたからです。 速度的にも、それほどの障害になるものでもありません。 考えられる要因として、 ・なにか操作上のミスがあるか、 ・シート上に計算式がたくさんあって、ワークシートに変更を加えたときに負荷がかかる のかもしれません。このため下記のコードでは、いったん手動計算にしています。 ●コードを再提示します。 変更点は以下。 （コードで■をつけています。） 1. 0.05とか0.03の閾値を定数として最初に定義しました。 2. 上下に同一距離のものがあったら小さい方を採用するよう修正. 3. 対象物aのサンプル番号が有っても対象物bのサンプル番号が無い場合への対応 重複して恐縮ですが、全体を再掲します。 Option Explicit Const threshold As Double = 0.03 ' ■ 閾値を定数として宣言 Dim ws1 As Worksheet, ws2 As Worksheet Sub main() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Call testPhase1 Call testPhase2 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub testPhase1() Const 最大数 As Long = 100 '1サンプル当りのデータ最大数(仮置き数値） Dim wsd As Worksheet Dim ws As Worksheet Dim x1 Dim x2 Dim t2 As Range Dim r As Range, a As Range, b As Range Dim acount&, i&, j&, ichi&, k&, n&, mn& Dim former& Dim diff As Double Dim mat Dim ans Dim flag As Boolean Set wsd = Worksheets("Data") Set r = wsd.Range("B7", wsd.Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants) ReDim mat(1 To 最大数, 1 To r.Areas.Count) '(1) Outlierを検出する（結果は配列matに保持) For Each a In r.Areas acount = acount + 1 x1 = a.Resize(, 6).Value flag = False For Each b In wsd.Range("N7", wsd.Range("N" & Rows.Count).End(xlUp)) _ .SpecialCells(xlCellTypeConstants).Areas x2 = b.Resize(, 6).Value If x1(2, 1) = x2(2, 1) Then flag = True Set t2 = b.Columns(1) Set t2 = Intersect(t2, t2.Offset(3)) '最初の3行は捨てる k = 1: mat(k, acount) = x1(2, 1): k = k + 1 'caseNo j = 0 For n = 4 To UBound(x1, 1) 't2の範囲を限定したところを対象に、最近接値を検索する ans = mostNearest(x1(n, 1), t2, j) mn = ans(0) diff = ans(1) If Abs(diff) < threshold Then j = ans(0) ' threshold 未満の近さのときだけ、マッチしたものとし、 '以後の検索ではマッチさせない End If ' power 条件で判定 If Abs(diff) < threshold Then If x1(n, 6) / x2(mn + 3, 6) >= 5 Then ' mat(k, acount) = x1(n, 1): k = k + 1 End If Else If x1(n, 6) / 1 >= 5 Then mat(k, acount) = x1(n, 1): k = k + 1 End If End If Next n Exit For '一度マッチしたら抜ける。bに同じNoのものがあっても相手をしない。 End If Next b ' 相手なしの場合 ■以下を追加。------------------- If flag = False Then k = 1: mat(k, acount) = x1(2, 1): k = k + 1 'caseNo For n = 4 To UBound(x1, 1) If x1(n, 6) / 1 >= 5 Then mat(k, acount) = x1(n, 1): k = k + 1 End If Next End If '■ここまでが追加分。------------ Next a ' (2) 配列 mat を"Phase1"シートに書き出す---------------------------- On Error Resume Next Set ws = Worksheets("Phase1") If Err.Number > 0 Then Set ws = Worksheets.Add(before:=Worksheets(1)) ws.Name = "Phase1" Else ws.Cells.ClearContents End If On Error GoTo 0 ws.Range("A1").Resize(UBound(mat, 1), UBound(mat, 2)).Value = mat End Sub Function mostNearest(a As Variant, rng As Range, ofst As Long) As Variant Dim r As Range Dim m As Variant Dim v1#, v2# Dim diff# Dim mn As Long Set r = Intersect(rng, rng.Offset(ofst)) 'マッチ済みのものを排除する If r Is Nothing Then mostNearest = Array(0, 10000) Else m = Application.Match(a, r, 1) 'aを超えない最大値がなければ、先頭が最近接値の候補 If IsError(m) Then mn = ofst + 1 diff = a - r(1, 1) 'aを超えない最大値があれば、それと次の近い方が最近接値 Else v1 = r(m, 1) v2 = r(m + 1, 1) If Abs(a - v1) <= Abs(a - v2) Then '■ 等号を追加 mn = ofst + m diff = a - v1 Else mn = ofst + m + 1 diff = a - v2 End If End If mostNearest = Array(mn, diff) End If End Function Sub testPhase2() '"Phase1"のデータをもとに、課題2の結果を"Analysis"シートに出力する Set ws1 = Worksheets("Phase1") On Error Resume Next Set ws2 = Worksheets("Analysis") If Err.Number > 0 Then Set ws2 = Worksheets.Add(before:=Worksheets(1)) ws2.Name = "Analysis" Else ws2.Cells.ClearContents End If On Error GoTo 0 '(1)"Phase1"シートから"Analysis"シートにデータを転記 Call データの転記 '(2)A,B 列を A列をキーに昇順にソート Call ソート '(3)前の時刻と0.05乖離しているかどうかでグループ内かを判定 Call time判定 '(4)結果を表にまとめる Call グルーピング 'Call グルーピング2 MsgBox "終了" End Sub Function データの転記() ' n 列のデータを ' 2列 A列(time) B列(波形種類)で、縦に並べる Dim p As Long Dim c As Variant Dim rng As Range Dim r As Range Dim caseNo As Long Dim numOfRows As Long With ws1 'Worksheets("Phase1") p = 1 For c = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column caseNo = .Cells(1, c).Value Set rng = .Range(.Cells(2, c), .Cells(.Rows.Count, c).End(xlUp)) numOfRows = rng.Rows.Count rng.Copy ws2.Cells(p, 1) 'ws2 は"Analysis"シート ws2.Cells(p, 2).Resize(numOfRows, 1).Value = caseNo p = p + numOfRows Next End With End Function Function ソート() 'A列(time)を最優先キーとして、昇順に並べ替える With ws2.Sort .SortFields.Clear .SortFields.Add Key:=ws2.Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange ws2.Range("A1").CurrentRegion .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Function Function time判定() '前の時刻と threshold 超で乖離していたら、3列目にflagとして1を建てる。 Dim k As Long With ws2 .Cells(1, 3).Value = 1 For k = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row If .Cells(k, 1).Value - .Cells(k - 1, 1).Value > threshold Then .Cells(k, 3).Value = 1 End If Next End With End Function Function グルーピング() '3列目が Blankの場合は、同一グループであるとして、 ' 1グループを1行に、波形種類をならべる。 Dim k As Long Dim colToWrite As Long Dim p As Long p = 0 With ws2 For k = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row If .Cells(k, 3).Value = 1 Then p = p + 1 colToWrite = 6 .Cells(p, 5) = .Cells(k, 1) .Cells(p, colToWrite) = .Cells(k, 2) Else '同じグループ内 colToWrite = colToWrite + 1 .Cells(p, colToWrite) = .Cells(k, 2) End If Next End With End Function 特段のことがなければ、私はこれで区切りとします。 コメントも適宜入れていますので、よく読んでいただきたいと思います。 テーマから私はてっきり学生さんかと思っていました。 仕事なら家のことに専念というわけにもいかず大変ですね。 1日も早い復旧を願っています。 # 投稿のやり方を間違えたので修正しました。(13:30) （γ） 2019/10/16(水) 13:01 ---- 皆さま、長きにわたりお助けいただいてありがとうございます。 返答が遅くなってしまい申し訳ありません。 （ぬまる猫） 2019/10/24(木) 09:23
... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201910/20191011155444.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97055 documents and 608280 words.
訪問者：