Results of 1 - 1 of about 37655 for IF (0.007 sec.)
- [[20190918140726]]
- #score: 1592
- @digest: 66fc29e7f07156e924b5112538ab5ce1
- @id: 80808
- @mdate: 2019-10-09T22:24:56Z
- @size: 67059
- @type: text/plain
- #keywords: mysary (80451), acount (64842), mysleft (49484), mysright (49359), のti (40007), myskey (35356), mysmid (32097), quicksort (30109), preserve (25482), power (23498), time (21539), xlcelltypeconstants (17654), vv (16031), areas (14921), 似値 (14673), ubound (14430), lbound (13328), redim (13241), サン (12050), 大値 (10510), プル (9763), 近似 (9072), ンプ (8588), 業用 (8103), 表記 (8072), specialcells (7966), variant (7338), 最大 (7149), application (6775), soulman (6566), 未満 (6039), 該当 (5683)
- 『ややこしい比較』（ぬまる猫）
下記のようにデータが並んでいます。 A、B列はサンプル50（A1）のあるtimeに検出された信号のpowerが示されています。 サンプル50は51、52・・・・300まであり、一定間隔でtimeとpowerが表記されています。 C列、D列も同様に各サンプル(50、51、52・・・・300)ごとにtimeとpowerが表記されています。 time・powerの数は各サンプルで規則性なくばらばらです。 AB列とCD列を比較します。 各サンプルごとに、 A列のtimeでC列のtimeと近い値（差が0.05未満）となる似たtimeがある場合→該当するB列のpower/該当するD列のpower A列のtimeでC列のtimeと近い値（差が0.05未満）となる似たtimeがない場合→該当するB列のpower/1 これらの割り算の結果から、値が5以上であれば、該当するtimeを該当するサンプル番号の下に表記します。 例えば、サンプル50では、A列のtime1.446はC列のtime1.445に近いのでそれぞれ同じ行の1655/2549<5→表記なし 一方で、A列のtime2.049はC列に近いtimeがないので同じ行の3945/1>5→2.049をE列に表記します。 この表記を行う方法を教えてほしいです。 A B C D E F G H ・・・・ 1 50 50 50 51 52 53 ・・・・ 2 Time power Time power 2.049 2.047 7.494 2.048 3 1.446 1655 1.445 2549 2.646 6.963 7.667 3.792 4 1.496 2829 1.49 3232 3.577 7.833 8.815 5.208 5 2.049 3945 2.161 4017 7.358 8.683 10.004 5.858 6 2.162 2566 2.29 1966 7.925 8.815 6.031 7 2.553 2093 2.554 1095 8.067 8.997 6.075 8 2.646 1457 2.825 1075 10.004 6.12 9 2.831 1527 2.997 1486 10.496 7.442 10 2.997 2817 3.188 1533 12.46 7.833 11 3.493 6342 3.492 7995 8.217 12 3.577 16944 3.543 5560 8.542 13 3.942 5348 3.576 7614 8.814 14 4.44 16449 3.941 4927 9.067 15 4.913 60583 4.438 9986 9.835 16 5.926 1944 4.911 32975 9.942 17 7.071 13315 7.069 7152 10.005 18 7.358 1450 7.83 5159 13.005 19 7.833 6631 8.146 3739 20 7.925 1966 13.573 2416 21 8.067 889 22 8.149 6882 23 8.349 1786 51 24 13.575 4774 Time power 25 1.485 1251 26 2.293 1594 27 51 2.553 1412 28 Time power 2.642 1390 29 2.047 2232 2.825 1162 30 2.292 1027 2.997 1348 31 2.555 1991 3.491 10377 32 2.645 1293 3.542 7825 33 2.832 2346 3.575 8468 34 2.998 3183 3.941 7928 35 3.493 8292 4.438 14061 36 3.578 19379 4.911 48583 37 3.942 8091 5.423 2646 38 4.44 24090 5.934 2015 39 4.914 90931 6.632 1684 40 5.425 1786 7.069 12838 41 5.925 5275 7.356 4618 42 6.634 2610 7.492 1716 43 6.963 1028 7.583 1568 44 7.071 24454 7.783 1680 45 7.358 6266 7.83 21890 46 7.494 2461 8.068 2616 47 7.583 1272 8.145 13726 48 7.783 1620 8.345 1458 49 7.833 30279 9.163 950 50 8.072 2901 9.23 954 51 8.149 25580 13.573 13028 52 8.349 3353 18.578 1139 53 8.683 995 54 8.815 1941 55 8.997 1401 52 56 9.234 2199 Time power 57 10.004 1144 1.473 2764 58 10.496 956 1.592 21849 59 12.46 1756 3.492 2956 60 13.575 24713 3.542 2065 61 18.58 1608 3.575 2380 62 3.941 1661 63 4.438 4507 64 52 4.911 19282 65 Time power 7.069 3113 66 1.474 4962 7.356 2063 67 1.593 30328 7.831 9818 68 3.494 2137 8.146 6553 69 3.577 5413 13.573 9794 70 4.441 7585 71 4.913 35629 72 7.071 5981 53 73 7.357 2855 Time power 74 7.494 1601 1.592 102783 75 7.667 1451 2.293 3654 76 7.833 13574 2.553 3195 77 8.149 12739 2.646 2151 78 8.815 2952 2.829 5228 79 10.004 1773 3.001 3301 80 13.575 18675 3.195 1098 81 3.491 29975 82 3.542 18623 83 53 3.575 20295 84 Time power 3.942 1405 85 1.593 145674 4.438 35625 86 2.048 3764 4.911 119243 87 2.295 2232 6.631 2537 88 2.554 4906 6.958 1555 89 2.645 2711 7.355 10901 90 2.832 9662 7.497 7452 91 2.999 5738 7.69 1769 92 3.494 23450 7.783 1132 93 3.577 46223 7.83 33869 94 3.792 1997 8.067 1200 95 3.944 3870 8.145 47126 96 4.44 59625 8.811 1617 97 4.913 227871 8.933 1619 98 5.208 1181 8.998 2058 99 5.858 966 9.163 4235 100 6.031 1403 9.231 4965 101 6.075 1884 12.458 2715 102 6.12 1436 12.88 1597 103 6.633 4386 13.133 1077 104 6.962 2415 13.378 1292 105 7.357 14799 13.573 51749 106 7.442 1709 13.997 2830 107 7.497 9878 18.579 2309 108 7.691 2304 109 7.783 1136 110 7.833 46489 54 111 8.067 1240 Time power 112 8.149 89192 1.473 4180 113 8.217 1888 1.592 21389 114 8.542 1018 3.491 16000 115 8.814 5007 3.542 6565 116 8.938 2175 3.575 4888 117 9 2084 4.438 25387 118 9.067 1412 4.911 34848 119 9.165 4917 6.072 1442 120 9.234 9908 7.323 2874 121 9.835 1129 7.358 1658 122 9.942 2150 7.689 2394 123 10.005 5085 7.83 3481 124 12.461 4640 7.952 4854 125 13.005 1602 8.144 3533 126 13.143 2345 8.414 2935 127 13.378 1753 8.808 961 128 13.575 97832 8.934 3115 129 14 5428 9.231 11644 130 18.58 3054 10.672 1373 131 13.573 7113 ＜ 使用 Excel:Excel2013、使用 OS:Windows7 ＞ ---- もし、A列が1.446でC列に1.445と1.447があった場合にはどちらを持ってくるのだろうか? （ねむねむ） 2019/09/18(水) 14:29 ---- もう一つ。 Timeが50以上になることはあるのだろうか? （ねむねむ） 2019/09/18(水) 14:32 ---- そのパターンはないものとします。また、0.05未満が複数ある場合はより値差が少ないほうを取ります。 timeは最大0.005〜25です。 （ぬまる猫） 2019/09/18(水) 14:36 ---- 重ねて質問ですまないがデータ全体は最大で何行になるだろうか? （ねむねむ） 2019/09/18(水) 15:30 ---- 多く見積もっても25000以下になります。 （ぬまる猫） 2019/09/18(水) 15:35 ---- 数式で作業列を使うものを作ってみたが（E列からH列を作業列として使い、I列から右へ抜出結果を表示する） すでにA列からD列に値がある場合はいいが（それでも少々時間がかかるが）式を入れた状態でA列からD列の値を 変更した場合にはかなり時間がかかるがそれでもいいだろうか? （ねむねむ） 2019/09/18(水) 16:26 ---- はい、お願いします。 （ぬまる猫） 2019/09/18(水) 16:35 ---- まず E3セル:=IF(B3="","",IF(AND(A1>=50,A1<>"Time"),A1,E2)) F3セル:=IF(D3="","",IF(AND(C1>=50,C1<>"Time"),C1,F2)) G3セル:=IF(E3="","",MIN(IF(F$3:F$25000=E3,ABS(C$3:C$25000-A3),""))) H3セル:=IF(E3="","",IF(B3/IF(G3<0.05,SUMIFS(D$3:D$25000,F$3:F$25000,E3,C$3:C$25000,"<="&A3+G3,C$3:C$25000,">="&A3-G3),1)>=5,ROW(),"")) と入力。 （ねむねむ） 2019/09/18(水) 16:42 ---- この時G3セルの式はShiftキーとCtrlキーを押しながらEnterキーで式を確定してくれ。 (確定後、式が{}で囲まれればOK） その後各セルの式を下へフィルコピーしてくれ。 （ねむねむ） 2019/09/18(水) 16:44 ---- 次にI1セルからIY1セルまで50から300と入力しておく。 そしてI2セルに =IFERROR(INDEX($A:$A,SMALL(IF($E$3:$E$25000=I$1,$H$3:$H$25000,""),ROW(A1)),),"") と入力してShift+Ctrl+Enter。 その後右及び下へフィルコピーで。 （ねむねむ） 2019/09/18(水) 16:47 ---- かなり重い式なので実用に耐えない場合は他の人からのマクロなどでの回答を待ってみてくれ。 （ねむねむ） 2019/09/18(水) 16:48 ---- 確かにすさまじい重さですね。でもありがとうございます。 ひとまず、これでやってみます。 （ぬまる猫） 2019/09/18(水) 17:06 ---- どなたかVBAで算出する方法を教えていただけませんか。 Excel関数だと、ほとんど固まって落ちてしまいます。 助けてください。 （ぬまる猫） 2019/10/01(火) 16:51 ---- サンプル50では3.577が出ないが、5.926、8.349が出る。 解釈が間違っているのならそれぞれの理由を教えてください。 Sub test() Dim x1, x2, y1, y2 Dim r As Range, a As Range Dim acount As Long, i As Long, j As Long, ichi As Long, k As Long Dim xx Dim mn As Double ' dim t1 as single:t1 = Timer Set r = Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants) '.Areas ReDim xx(1 To 100, 1 To r.Areas.Count) '1 to 100の100は1サンプル当り100までとしている。超えてエラーが出るなら大きくして For Each a In r.Areas acount = acount + 1 x1 = a.Resize(, 2).Value x2 = Range("C1", Range("C" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas(acount).Resize(, 2).Value y1 = WorksheetFunction.Index(x1, 0, 1) y2 = WorksheetFunction.Index(x2, 0, 1) y2(1, 1) = 0: y2(2, 1) = 0 k = 1: xx(k, acount) = x1(1, 1): k = k + 1 ichi = 3 For i = 3 To UBound(y1) ichi = WorksheetFunction.Match(y1(i, 1), y2, 1) mn = y1(i, 1) - y2(ichi, 1) For j = ichi + 1 To UBound(y2) If y2(j, 1) - y1(i, 1) > mn Then Exit For Else mn = y2(j, 1) - y1(i, 1) If mn > 0.05 Then Exit For End If Next If mn < 0.05 Then If x1(i, 2) / x2(j - 1, 2) > 5 Then xx(k, acount) = x1(i, 1): k = k + 1 End If Else If x1(i, 2) > 5 Then xx(k, acount) = x1(i, 1): k = k + 1 End If End If Next Next Range("E1").Resize(UBound(xx), UBound(xx, 2)).Value = xx ' MsgBox (Timer - t1) / 131 * 25000 End Sub （kazuo） 2019/10/01(火) 21:09 ---- ちょっろ書いてみました。。。 一応↓みたいになりました。。。 すみません。もう寝ますzzzzzzzzzzzzzzzzzzz おやすみなさい。。。。。 50 51 52 53 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 5.858 7.925 8.997 6.031 8.067 10.004 6.075 8.349 10.496 6.12 12.46 7.442 8.217 8.542 9.067 9.835 9.942 10.005 13.005 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 xx As Variant Dim r As Range Dim rr As Range 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 ReDim y(0) kk = 0 ReDim w(kk) Application.ScreenUpdating = False Columns("C:C").Insert Shift:=xlToRight For Each r In Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas v = r.Resize(, 2).Value For Each rr In Range("D1", Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas If r(1, 1) = rr(1, 1) Then w(kk) = r(1, 1) kk = kk + 1 ReDim Preserve w(kk) 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 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)) > 0.05 Then If v(i, 2) / vv(x, 2) > 5 Then z(k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) End If Else If Abs(v(i, 1) - vv(nn, 1)) > 0.05 Then If v(i, 2) / vv(x, 2) > 5 Then z(k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) End If End If End If End If Else 'ちょうどの場合 If v(i, 2) / vv(x, 2) > 5 Then z(1, k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) End If End If Next y(n) = z n = n + 1 ReDim Preserve y(n) Exit For End If Next Next k = 1 w = Application.Transpose(w) 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) Next Next Range("H1").Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w) Columns("C:C").Delete Shift:=xlToLeft Application.ScreenUpdating = True Erase v, vv, y, z, w End Sub 失礼しました。答え合わせをしました。 （SoulMan） 2019/10/02(水) 00:40 ---- （kazuo）（SoulMan） ご回答ありがとうございます。 kazuoさんに教えていただいた方法でうまくいきました。 追加でお聞きしたいのですが、 A B C D E F G H I J K L M N O P Q R S 1 2 3 4 5 6 7 22 18 8 50 50 9 time power time power 10 1.446 1655 1.445 2549 11 1.496 2829 1.49 3232 12 2.049 3945 2.161 4017 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 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 13 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 15 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 80 7.357 2855 81 7.494 1601 82 7.667 1451 83 7.833 13574 84 8.149 12739 85 8.815 2952 86 10.004 1773 87 13.575 18675 上記の数字の並びが変更で、開始セルがずれて、何列か空白の列が入ります。記載していませんが、開始セル（B7）前や列の空白には無関係な数字や文字が入ったり、または空白となります。 この変更を踏まえるとどのようなVBAとなりますか。 （ぬまる猫） 2019/10/02(水) 14:04 ---- 考えましたが、スピード向上出来そうに無いので、レイアウトの変更のみにしました。 '★ の箇所 以前のコードにミスがありましたので、以前のコードを使用する場合は適用願います。 Sub test改() Const 書き出しセル As String = "Z1" '書き出しセルを指定する 本例では50の位置がZ1セルになります Const 最大数 As Long = 100 '1サンプル当りのデータ最大数 Dim x1, x2, y1, y2 Dim r As Range, a As Range Dim acount As Long, i As Long, j As Long, ichi As Long, k As Long Dim xx Dim mn As Double Set r = Range("B7", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants) ReDim xx(1 To 最大数, 1 To r.Areas.Count) For Each a In r.Areas acount = acount + 1 x1 = a.Resize(, 6).Value x2 = Range("N7", Range("N" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas(acount).Resize(, 6).Value y1 = WorksheetFunction.Index(x1, 0, 1) y2 = WorksheetFunction.Index(x2, 0, 1) y2(1, 1) = 0: y2(2, 1) = 0: y2(3, 1) = 0 k = 1: xx(k, acount) = x1(2, 1): k = k + 1 ' ichi = 3 '★消し忘れです For i = 4 To UBound(y1) ichi = WorksheetFunction.Match(y1(i, 1), y2, 1) mn = y1(i, 1) - y2(ichi, 1) For j = ichi + 1 To UBound(y2) If y2(j, 1) - y1(i, 1) > mn Then Exit For Else mn = y2(j, 1) - y1(i, 1) If mn > 0.05 Then Exit For End If Next If mn < 0.05 Then If x1(i, 6) / x2(j - 1, 6) >= 5 Then '★バグ訂正 > → >= (5を超える → 5以上) xx(k, acount) = x1(i, 1): k = k + 1 End If Else If x1(i, 6) / 1 >= 5 Then '★バグ訂正 > → >= (5を超える → 5以上)、一応 /1 を追加 xx(k, acount) = x1(i, 1): k = k + 1 End If End If Next Next Range(書き出しセル).Resize(UBound(xx), UBound(xx, 2)).Value = xx End Sub （kazuo） 2019/10/02(水) 23:17 ---- 方法は色々あるでしょうが、、せっかく動くコードがあるのですから それにレイアウトを合わせてみてはどうでしょうか??? 一応↓みたいになりました。。。 Sheet1のH1に出力します。。。出力先は適当に変更してください。。。 では、、では、、、 50 51 52 2.049 6.963 7.494 2.646 8.683 7.667 5.926 8.815 8.815 7.358 8.997 10.004 7.925 10.004 8.067 10.496 8.349 12.46 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 xx As Variant Dim r As Range Dim rr As Range 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 ReDim y(0) kk = 0 ReDim w(kk) Application.ScreenUpdating = False If Not Evaluate("=ISREF(作業用!A1)") Then Sheets.Add.Name = "作業用" With Sheets("作業用") .Cells.Clear Sheets("Sheet2").UsedRange.Copy Destination:=.Range("A1") .Range("B:E,G:L,N:Q").Delete Shift:=xlToLeft .Columns("C:C").Insert Shift:=xlToRight For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas r(1, 1).Clear Next For Each rr In .Range("D1", .Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas rr(1, 1).Clear Next For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas v = r.Resize(, 2).Value For Each rr In .Range("D1", .Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas If r(1, 1) = rr(1, 1) Then w(kk) = r(1, 1) kk = kk + 1 ReDim Preserve w(kk) k = 1 ReDim z(1 To k) vv = rr.Resize(, 2).Value For i = LBound(v, 1) + 3 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 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) 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) End If End If End If Else 'ちょうどの場合 If v(i, 2) / vv(x, 2) > 5 Then z(1, k) = v(i, 1) k = k + 1 ReDim Preserve z(1 To k) End If End If Next y(n) = z n = n + 1 ReDim Preserve y(n) Exit For End If Next Next k = 1 w = Application.Transpose(w) 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) Next Next ' .Columns("C:C").Delete Shift:=xlToLeft Application.DisplayAlerts = False .Delete Application.DisplayAlerts = False End With With Sheets("Sheet1") .Range("H1").Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w) End With Application.ScreenUpdating = True Erase v, vv, y, z, w End Sub あかん。。。胸のカラータイマーが限界です。。。 （SoulMan） 2019/10/02(水) 23:40 ---- kazuoさんの式でうまくいきました。ありがとうございます。 SoulManさんもタイマーが鳴り響く中ありがとうございます。 さて、もう少しお力をお借りしたいのです。 上記VBAで算出したサンプル50〜300(すいません、実際は301まででした)のtimeは 50〜112(sheet1)、113-175(sheet2)、176〜238(sheet3)、238〜301(sheet4)の4つのsheetにわけて表記されます。新しいsheetに、これら全てのサンプルのtimeを順に並べて、各timeに該当するサンプル名を下記のように羅列したいです。 値が近いあるいは同じtime（差が0.05未満）の場合はその中で一番低い値を表記します。その際表記するサンプル名は 近い値すべてになります。 例えば、サンプル名50の2.049とサンプル名51の2.047は差が0.05未満なので、最小の値2.047のみ表記し、該当サンプル名には50、51が入ることになります。 (例:サンプル50〜52の場合) 1 Z AA AB 2 50 51 52 3 2.049 2.047 7.494 4 2.646 6.963 7.667 5 5.926 8.683 8.815 6 7.358 8.815 10.004 7 7.925 8.997 8 8.067 10.004 9 8.349 10.496 10 12.46 1 A B C 2 2.047 50 51 3 2.646 50 4 5.926 50 5 6.963 51 6 7.358 50 7 7.494 52 8 7.667 52 9 7.925 50 10 8.067 50 11 8.349 50 12 8.683 51 13 8.815 51 52 14 8.997 51 15 10.004 51 52 16 10.496 51 17 12.46 51 （ぬまる猫） 2019/10/03(木) 09:58 ---- こんばんは! 一応、答え合わせをしました。。。 ↓こんな感じになりました。。。 SoulManさんのでうまくいきました。。。って言われたいね(^^; 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 51 50 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 xx As Variant Dim r As Range Dim rr As Range Dim u As Range 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 ReDim y(0) 'kk = 0 ReDim w(0) Application.ScreenUpdating = False If Not Evaluate("=ISREF(作業用!A1)") Then Sheets.Add.Name = "作業用" With Sheets("作業用") .Cells.Clear Sheets("Sheet2").UsedRange.Copy Destination:=.Range("A1") .Range("B:E,G:L,N:Q").Delete Shift:=xlToLeft .Columns("C:C").Insert Shift:=xlToRight For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas 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 .Range("D1", .Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas If u Is Nothing Then Set u = r(1, 1) Else Set u = Union(u, rr(1, 1)) End If Next u.Clear For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas v = r.Resize(, 2).Value For Each rr In .Range("D1", .Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas If r(1, 1) = rr(1, 1) Then w(kk) = r(1, 1) kk = kk + 1 ReDim Preserve w(kk) 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 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) 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) 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) End If End If Next y(n) = z n = n + 1 ReDim Preserve y(n) Exit For End If Next 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, 1, LBound(s, 1), UBound(s, 1) k = 1 j = 0 ReDim ss(LBound(s, 1) To UBound(s, 1), 1 To UBound(y)) For i = LBound(s, 1) To UBound(s, 1) If i = UBound(s, 1) Then If Abs(s(i, 1) - s(i - 1, 1)) < 0.05 Then j = j + 1 ss(j, 1) = s(i, 1) ss(j, 2) = s(i, 2) ss(j, 3) = s(i - 1, 2) i = i + 1 Else j = j + 1 ss(j, 1) = s(i, 1) ss(j, 2) = s(i, 2) End If Else If Abs(s(i, 1) - s(i + 1, 1)) < 0.05 Then j = j + 1 ss(j, 1) = s(i, 1) ss(j, 2) = s(i, 2) ss(j, 3) = s(i + 1, 2) i = i + 1 Else j = j + 1 ss(j, 1) = s(i, 1) ss(j, 2) = s(i, 2) End If End If Next Application.DisplayAlerts = False .Delete Application.DisplayAlerts = False End With With Sheets("Sheet1") .Range("H1").Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w) .Range("M1").Resize(j, UBound(ss, 2)).Value = ss End With Application.ScreenUpdating = True Set u = Nothing Erase v, vv, y, z, w, s, ss End Sub Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight 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 MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) ¥ 2, MySKey) i = MySLeft j = MySRight Do 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 i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1 If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight End Sub 長編になっちゃったね(^^; 今度こそ頼むよ!SoulMan! しゅわっち Or じゅわっち!!! 思わず回答しちゃったけど、、こんなことになるとは、、、 v(=∩_∩=)v （SoulMan） 2019/10/03(木) 21:28 ---- こんばんは ^^ 。。。複雑な条件処理を短時間で。。。さすがですね。 今回は難しすぎて。検証できていません。済みません。m(_ _)m 自分でも作成中ですが。嵌っています。 (￣▽￣) ← 最近思考力がにぶっている年寄りでした。〜いや、前からかも^^;;; お手本にさせて頂きます。でわでわ m(_ _)m （隠居じーさん） 2019/10/03(木) 23:34 ---- こんばんは! 複雑じゃないです(笑) 順番に書いただけです 会社では、いつも無理難題言われてますから(^^;; いつもありがとうございます😊 （SoulMan） 2019/10/03(木) 23:59 ---- SoulManさんのでうまくいきました。 すごすぎます。ただ、複雑すぎて私には解読できません汗 仮に、サンプル50〜301が1シートで表記されていれば、もう少しシンプルの式になりますでしょうか。 VBA初心者のため、いざ編集しようと思ってもうまくいきません。 お願いばかりいってすいません。 kazuoさんもご覧であれば、サポートしてくださるとたいへん助かります。 何卒よろしくお願いします。 （ぬまる猫） 2019/10/04(金) 08:58 ---- あと情報ですいません。 サンプル50〜301は必ずしも全部あるわけではないことがわかりました。 例えばサンプル63でひとつもpowerを検出しなければ、サンプル63じたい表記されなくなり、サンプル62とんでサンプル64の表記になります。 （ぬまる猫） 2019/10/04(金) 09:12 ---- SoulManさんのコードはバグ（S10に25を入れても1.446が表示されなかった)が修正されていますし、 私のコードの無駄なy1と0.05判定を削除しても10%近く早いです。 ＞VBA初心者のため、いざ編集しようと思ってもうまくいきません kazuoのなら編集出来そうですか? 解らないところがあったら質問してください。殆どのかたが回答してくれると思います。 私は基本的に、品評会に加わるつもりは有りません。 ＞サンプル63じたい表記されなくなり、サンプル62とんでサンプル64の表記になります。 サンプルが無くとも連番のサンプル名の列を表示するということですか? 一連の作業かも知れませんが、当初の質問と違っています。 スレッドを立て直した方が別のアプローチが貰えて良いと思います。 ただ、仕様の不明点が有ります。 ＞値が近いあるいは同じtime（差が0.05未満）の場合はその中で一番低い値を表記します。 ＞その際表記するサンプル名は近い値すべてになります。 例）サンプル名:Time、で表記 50:1.45、51:1.41、52:1.49、53:1.50 の時、 1. timeの基準はどこですか? 1.41 50 51 一番低い値を基準 1.49 52 53 1.41 50 51 52 中心に近い値を基準 1.50 53 1.41 50 51 52 53 近接する全て値を基準 2. サンプル名の並びは 1.41 50 51 サンプル名昇順 1.41 51 50 Time昇順 基準無し （kazuo） 2019/10/04(金) 20:12 ---- こんばんは! 出来てよかったです。正直、ほっとしてます。。。 一見、複雑そうに見えるかもしれませんが、見る人がみれば、、実は、大したことないんですよ(^^; やたらと変数が多いのが私のコードの特徴で欠点でもある様に思います。その辺を改善されたらいいと思います。。 今はレイアウトを整える部分も一緒になってますから、その辺を整理されらいいでしょう いきなり編集しようとしても難しいでしょうから私からの私見的なアドバイスをいくつか、、、あくまでも私見です。 1.参考にしたい人のコードを模写する 憧れの人のコードをそっくり模写するのです。(好きな人のコードがいいです。方向性が違う人のコードをまねても上手くいきません。←多分???) この時、大切なのは、変数名を自分の変数名(自分の言葉に)に置き換えることです。 例えば、私のカウンターは、k か n i j 配列は MyA 入れ物は MyAry などです。(日本語も有効です。) 最近は、格好つけて v とか w とか使ってますけど、、昔は、ほとんどこれです。(^^; 自分の変数名(自分の言葉に)に変えるだけで理解度がぐっと上がります。 そんなことを繰り返しているうちに今回、提示した程度のコードなら、直ぐにとは言わなくても書ける様になります。 質問の日本語を既にお書きになることができるのですから、、、、 2.コードはPrintOutする 短いコードならいいのですが長くなるとやっぱり紙ベースがいいです。 私の書棚には自分が書いたコードのスクラップが、、何冊あるかなぁ???数えたことないけど、、かなりあります。(笑) 前項でもお話しましたが、既に日本語では構文が書けていらっしゃるのですから、それをコードにするだけです。 実際に私も何度も書き直しているのですから一回ではなかなか書けないものなのです。書ける人が本当にすごい人、、、です。 コードの中にトピ主さんの言葉をいれていますから参考にしてみて下さい。 3.回答者側からコメントしてください っとここまでもっともらしいことを書きましたが今回のトピ主さんのスキルはかなり高いと思ってます。 回答者みたいなことを永くやってるとなんとなくわかるんですよね 私は必ずしも回答者の方が質問者さんよりスキルが高いとは思っていなくて私よりスキルの高い質問者さんは何百何千億といっらしゃるわけで、、、 あと、全くヒットしなかった場合のコードも載せておきます。 ヒットしなかった場合のコードがないのは、私のコードの特徴でもあります。(おおぉぉっいい!!所詮、なぐり書ですから。。。(笑)) 長くなってしまったので上のコードと差し替えようかと思いましたが、、違いを参考にされる方もいらっしゃるかもしれませんので、、、 おらんかな???(笑) (回答する側もスピードというかぁ、、タイミングがあります。自分のタイミングで書くことが出来れば違ってくるんでしょうけど。。) ってなかんじですかね。。あんまり偉っそぶってもボロが出ますしね。 どこかでまたお逢いすることを楽しみしています。。。。 では、、では、、また、、、 50 52 2.049 7.494 2.646 7.667 5.926 8.815 7.358 10.004 7.925 8.067 8.349 2.049 50 2.646 50 5.926 50 7.358 50 7.494 52 7.667 52 7.925 50 8.067 50 8.349 50 8.815 52 10.004 52 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 r As Range Dim rr As Range Dim u As Range 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 ReDim y(0) ReDim w(0) Application.ScreenUpdating = False If Not Evaluate("=ISREF(作業用!A1)") Then Sheets.Add.Name = "作業用" With Sheets("作業用") .Cells.Clear Sheets("Sheet2").UsedRange.Copy Destination:=.Range("A1") .Range("B:E,G:L,N:Q").Delete Shift:=xlToLeft .Columns("C:C").Insert Shift:=xlToRight For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas 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 .Range("D1", .Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas If u Is Nothing Then Set u = r(1, 1) Else Set u = Union(u, rr(1, 1)) End If Next u.Clear For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas v = r.Resize(, 2).Value For Each rr In .Range("D1", .Range("D" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas 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 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) 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) 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) End If End If Next y(n) = z n = n + 1 ReDim Preserve y(n) Exit For End If Next 'ヒットしたら If k > 1 Then w(kk) = r(1, 1) kk = kk + 1 ReDim Preserve w(kk) Else n = n - 1 ReDim Preserve y(n) 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, 1, LBound(s, 1), UBound(s, 1) k = 1 j = 0 ReDim ss(LBound(s, 1) To UBound(s, 1), 1 To UBound(y)) For i = LBound(s, 1) To UBound(s, 1) If i = UBound(s, 1) Then If Abs(s(i, 1) - s(i - 1, 1)) < 0.05 Then j = j + 1 ss(j, 1) = s(i, 1) ss(j, 2) = s(i, 2) ss(j, 3) = s(i - 1, 2) i = i + 1 Else j = j + 1 ss(j, 1) = s(i, 1) ss(j, 2) = s(i, 2) End If Else If Abs(s(i, 1) - s(i + 1, 1)) < 0.05 Then j = j + 1 ss(j, 1) = s(i, 1) ss(j, 2) = s(i, 2) ss(j, 3) = s(i + 1, 2) i = i + 1 Else j = j + 1 ss(j, 1) = s(i, 1) ss(j, 2) = s(i, 2) End If End If Next Application.DisplayAlerts = False .Delete Application.DisplayAlerts = False End With With Sheets("Sheet1") .Range("H1").Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w) .Range("M1").Resize(j, UBound(ss, 2)).Value = ss End With Application.ScreenUpdating = True Set u = Nothing Erase v, vv, y, z, w, s, ss End Sub Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight 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 MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) ¥ 2, MySKey) i = MySLeft j = MySRight Do 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 i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1 If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight End Sub （SoulMan） 2019/10/04(金) 20:19 ---- 横入り。 私も、kazuoさん指摘の論点が気になっていました。 timeをグルーピングする基準（と代表値の選択の基準）が曖昧だと思います。 特に、全てのサンプルを同時に相手にするのであれば。 そもそも、どんな統計量を計算しようとしているのか、 それを説明されたほうが考えやすいですね。 なにか、その段階で試行錯誤されている印象です。 その段階でむやみにコードを作ろうとすると、 皆さんのサポートが無駄になりかねません。 そして、スレッドを改めたほうがよいという指摘にも同感ですね。 （γ） 2019/10/05(土) 11:41 ---- みなさま、貴重なご意見ありがとうございます。 おっしゃる通りでございます。 改めてスレッドをたててご質問させていただこうと思います。 ちなみに 1. timeの基準はどこですか? このパターンも考えましたが、おそらく生じないと考えています。ただし、絶対とは言い切れないので 仮に発生した場合は近接するすべて値を基準としたいです。 1.41 50 51 52 53 近接する全て値を基準 2. サンプル名の並びは 1.41 50 51 サンプル名昇順 となります。 （ぬまる猫） 2019/10/07(月) 15:07 ---- また ＞サンプル63じたい表記されなくなり、サンプル62とんでサンプル64の表記になります。 サンプル62 サンプル64 のようにサンプル63のtimeがない場合は連番のサンプル名の列サンプル名は表示しません。 （ぬまる猫） 2019/10/07(月) 15:15 ---- こんばんは! 逃げきりを図ろうと思ったんですけど、、だめみたいですね(^^; 親がないときに飛ばすのは前回対応済ですよね? 項目の並び替えを追加して、、、 あとは、、あるだけ増えるところですけど、、、ちょっとわけが分からくなっちゃいました(^^; いい線いってると思いますが、、サンプルを作ってる暇がないもんで。。。。 一応↓みたいになってます。。。 あとは、、応用して頂けると助かります(笑) では、、では、、 もう寝ますzzzzzzzzzzzzzzzzzzzzzzz 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 ReDim y(0) ReDim w(0) Application.ScreenUpdating = False If Not Evaluate("=ISREF(作業用!A1)") Then Sheets.Add.Name = "作業用" With Sheets("作業用") .Cells.Clear Sheets("NewTD").UsedRange.Copy Destination:=.Range("A1") .Range("B:E,G:L,N:Q").Delete Shift:=xlToLeft .Columns("C:C").Insert Shift:=xlToRight '並び替えを追加 For Each r In .Range("A:E").SpecialCells(xlCellTypeConstants, 3).Areas Set r = r.CurrentRegion.Offset(3).Resize(r.CurrentRegion.Rows.Count - 3) r.Sort Key1:=r.Cells(1, 1), order1:=xlAscending Next 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 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) 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) 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) End If End If Next y(n) = z n = n + 1 ReDim Preserve y(n) Exit For End If Next 'ヒットしたら If k > 1 Then w(kk) = r(1, 1) kk = kk + 1 ReDim Preserve w(kk) Else n = n - 1 ReDim Preserve y(n) 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, 1, LBound(s, 1), UBound(s, 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.01 Then s(i, 3) = 1 Else s(i, 3) = Empty End If Next k = 0 n = 0 最大値 = 0 ReDim z(0) For i = LBound(s, 1) To UBound(s, 1) If s(i, 3) = "" Then ReDim Preserve t(k) t(k) = s(i, 2) k = k + 1 ReDim Preserve y(n) y(n) = t If MyFlg = False Then ReDim Preserve z(n) z(n) = s(i, 1) MyFlg = True End If If 最大値 < k Then 最大値 = k Else k = 0 n = n + 1 ReDim Preserve t(k) t(k) = s(i, 2) k = k + 1 ReDim Preserve y(n) y(n) = t ReDim Preserve z(n) z(n) = s(i, 1) MyFlg = False End If Next ReDim ss(1 To n + 1, 1 To 最大値 + 1) For i = LBound(y) To UBound(y) ss(i + 1, 1) = z(i) If UBound(y(i)) > 0 Then OneQuickSort 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("Sheet1") .Cells.Clear .Range("A1").Resize(UBound(w, 2), UBound(w, 1)).Value = Application.Transpose(w) .Range("KA1").Resize(UBound(ss, 1), UBound(ss, 2)).Value = ss 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 MySKey As Long, ByVal MySLeft As Long, ByVal MySRight 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 MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) ¥ 2, MySKey) i = MySLeft j = MySRight Do 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 i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1 If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight End Sub Private Sub OneQuickSort(MySAry As Variant, ByVal MySLeft As Long, ByVal MySRight As Long) Dim MySMid As Long Dim i As Long Dim j As Long Dim MyStmp As String MySMid = MySAry((MySLeft + MySRight) ¥ 2) i = MySLeft j = MySRight Do 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 i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then OneQuickSort MySAry, MySLeft, i - 1 If MySRight > j + 1 Then OneQuickSort MySAry, j + 1, MySRight End Sub （SoulMan） 2019/10/08(火) 00:02 ---- こんばんは! 昨夜、登校してからよくよく考えたら判定は一度舐めて→それから集計して それを整形すればええんとちゃうん???って気が付きました。m(__)m 急がば回れですね(^^;一度に処理をしようとするから悩むんですよね。 Guitar と Vba は、 Don't Think Bee Feel!! 考えるな!感じろ!!!ですね ↑わちきの格言です。(しらんがなって(笑)） 上のコードは差し替えておきました。 というわけで、、これで完成形だと思いますが、、、どうでしょう??? ところで、ここからは余談ですけど、、皆さんは、コードを書くときどうしてますかぁ??? 私の場合は、、永ちゃんをガンガン聞きながら書いてます。。。 Rockしてるか?してないか?Rock出来るか?出来ないか?それで決まるGetYou!!!! いいね♪ 今日は、ちょっと早く帰って来たので胸のカラータイマーがちょっと元気 v(=∩_∩=)v これでファイナルアンサーとなります様に!!!!ぱんぱん では、、では、、、 （SoulMan） 2019/10/08(火) 20:12 ---- こんばんは ^^ 修正前のでも、テストの結果、たしかご注文通りだったように思いますです。(#^^#)v ↑ 単に、Soulmanさんのコード、実行しただけですけど。 今回のはまだやってません。。。これから。。。m(__)mm(__)mm(__)m 前半も、後半も、情報の整形が、かなりたいへんなよう〜ですね。← 感じただけです (￣▽￣)v。。。 でわでわ、ごきげんよう。。。わたしは、コーディング、 じ〜〜〜とPC、にらんでます。 ← （大笑）。。。 ! m(_ _)m （隠居じーさん） 2019/10/08(火) 21:25 ---- 隠居じーさん さん こんばんは! いつもありがとうございます。 奥さんにいつも「やかましい!!!」って怒られてます(笑) だって、、調子がでないんですもの(^^; これからもよろしくお願いいたします。。。。。 （SoulMan） 2019/10/08(火) 21:32 ---- SoulMan さんへ 家はもう奥さんに無視されてます（笑） こちらこそ、今後とも、宜しくお願い致します。。。。m(_ _)m ぬまる猫 さん 横入り。すみません （隠居じーさん） 2019/10/08(火) 21:58 ---- こんにちは ^^ ダミ-情報、こさえてみました。御不用でしたら、無視してくださいませ。^^; 今回は何回作成しても同じものが出来るようにしました。← あたりまえだろ（笑） もしお使いでしたら、シート名とか、表示位置は既存の物に合わせ変えて下さい。 アップしてませんが、私の作成したコードでは20数分かかります。←駄作に付き 恥ずかしくてアップ出来ません。作成件数等、てきとぉ〜に増減すればテスト用に は使えなくは無いかもです。(#^^#)。。。内容は。。。ぬまる猫さん にしかられ そぉですね。。。でわでわ m(_ _)m Option Explicit '********************************************************** '* RND * '* Int((最大値 - 最小値 +1 ) * Rnd + 最小値) * '* 50 - 301 * '********************************************************** Sub DummyTestDaterMaker() Dim i As Long Dim j As Long Dim Y As Long Dim Y2 As Long Dim X As Long Dim Z As Long Dim Z2 As Long Dim Snm As String Dim Cnt As Long Snm = "NewTD" Rnd (-1): j = 50: Y = 7: Y2 = 7: X = 1: Cnt = 1 With Worksheets(Snm) .Cells.Clear While j < 301 .Cells(Y, X) = Cnt Y = Y + 1 .Cells(Y, X) = j Y = Y + 1 .Cells(Y, X).Resize(, 2) = Array("Time", "Power") Y = Y + 1 Z = Int((50 - 10 + 1) * Rnd + 10) .Cells(Y2, X + 2) = Cnt Y2 = Y2 + 1 .Cells(Y2, X + 2) = j Y2 = Y2 + 1 .Cells(Y2, X + 2).Resize(, 2) = Array("Time", "Power") Y2 = Y2 + 1 For i = 1 To Z .Cells(Y, X) = Round((25 - 1 + 0.005) * Rnd + 0.005, 3) .Cells(Y, X + 1) = Int((99999 - 1 + 500) * Rnd + 500) Y = Y + 1 DoEvents Next Z2 = Int((5 - 1 + 2) * Rnd + 2) If Z Mod 2 Then Z2 = Z2 * -1 Z2 = Z2 + Z For i = 1 To Z2 .Cells(Y2, X + 2) = Round((25 - 1 + 0.005) * Rnd + 0.005, 3) .Cells(Y2, X + 3) = Int((99999 - 1 + 500) * Rnd + 500) Y2 = Y2 + 1 DoEvents Next Y = Y + Int((5 - 2 + 1) * Rnd + 2) Y2 = Y2 + Int((5 - 2 + 1) * Rnd + 2) j = j + 1: Cnt = Cnt + 1 DoEvents Wend 'AFMR .Range("B:E").Insert Shift:=xlToRight .Range("G:L").Insert Shift:=xlToRight .Range("N:Q").Insert Shift:=xlToRight '.Range(.Cells(1), .Cells(6, 18)) = "X" End With End Sub （隠居じーさん） 2019/10/09(水) 12:22 ---- 隠居じーさん さん サンプルコード作成 ありがとうございます。 ネーミングがおしゃれですね(^^; でも、そのままだと私のコードが走らなかったので私のコードの中にデータを昇降順に並び替えるコードを追加しました。 これは、ぬまる猫 さんのデータでも使えると思いますので問題ないと思います。 あと、↓これがエラーになるところとならないところがあるので x = Application.Match(v(i, 1), Application.Index(vv, 0, 1), 1) ↓これで逃げてます。。。(^^; If Not IsError(x) Then それから、、隠居じーさん さんのサンプルデータでは、、0.05 の範囲にない?と思いますので、、 ちょっときつくして↓にしてます。総チェックするところだけです。 If Abs(s(i - 1, 1) - s(i, 1)) > 0.01 Then なので、、解があってるかどうかはわかりませんが、、、まぁまぁ、、いい線いってるかな??? まぁまぁじゃ、、だめなんでしょうけど(^^; それから、データ数が多いので書き出しを A1 と KA1 にしてます。 上のコードは差し替えておきました。 では、、、では、、、 （SoulMan） 2019/10/09(水) 22:29 ---- こんばんは ^^ 。。。うぅ 変なサンプル作って済みません、m(_ _)m 。。。 かえって、混乱させていないか、心配です（あり得ない情報だったりして。。。^^;） ↑ にもかかわらず、テストを賜り、恐縮です。いま ZzzzZZZ。。状態ですので とりあえず、お礼と、お詫びまで。SoulManさん、すみません m(_ _)m あれこれ試しているのですが私自身が ← 混乱状態です (◎_◎;) （笑）また、明日、以降、整理して、SoulMan さんのコードを頼りに勉強してみます。 配列、万歳。。。 (#^^#)v でわでわ、ありがとうございました。 （隠居じーさん） 2019/10/09(水) 22:49 ---- 隠居じーさん さん こんばんは! 私はいつも学校でコードを書いてますが、あくまでサンプルだと思ってます。 実際の作業に応用する際には、すんなりと行かないものだと思ってます。 そこを応用していただければ、、と思ってます。。 隠居じーさん さんのサンプルコードは大変助かりました。 本当にありがとうございます。m(__)m これからもどうぞよろしくお願いいたします。 では、、では、、また、、、 （SoulMan） 2019/10/09(水) 22:58 ---- おはようございます。 ^^ そぉ〜おっしゃっていただければ、幸甚です。 でわ、また、、m(_ _)m （隠居じーさん） 2019/10/10(木) 07:24... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201909/20190918140726.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97040 documents and 608045 words.
訪問者：