[[20190918140726]]　『ややこしい比較』（ぬまる猫）　ページの最後に飛ぶ

『ややこしい比較』（ぬまる猫）

下記のようにデータが並んでいます。
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									
上記の数字の並びが変更で、開始セルがずれて、何列か空白の列が入ります。記載していませんが、開始セル（Ｂ７）前や列の空白には無関係な数字や文字が入ったり、または空白となります。
この変更を踏まえるとどのような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)の４つの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　の時、

１．　timeの基準はどこですか？

 1.41 50 51　　　　　　一番低い値を基準
 1.49 52 53		
 1.41 50 51 52　　　　 中心に近い値を基準
 1.50 53		
 1.41 50 51 52 53　　　近接する全て値を基準

２．　サンプル名の並びは

 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

 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

みなさま、貴重なご意見ありがとうございます。

おっしゃる通りでございます。
改めてスレッドをたててご質問させていただこうと思います。
ちなみに
１．　timeの基準はどこですか？
このパターンも考えましたが、おそらく生じないと考えています。ただし、絶対とは言い切れないので
仮に発生した場合は近接するすべて値を基準としたいです。

 1.41 50 51 52 53　　　近接する全て値を基準

２．　サンプル名の並びは

 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

 こんばんは　＾＾
修正前のでも、テストの結果、たしかご注文通りだったように思いますです。(#^^#)ｖ
　　　　　　　　↑　　
 単に、Soulmanさんのコード、実行しただけですけど。
今回のはまだやってません。。。これから。。。m(__)mm(__)mm(__)m
 前半も、後半も、情報の整形が、かなりたいへんなよう～ですね。←　感じただけです
(￣▽￣)ｖ。。。
でわでわ、ごきげんよう。。。わたしは、コーディング、
じ～～～とＰＣ、にらんでます。　←　（大笑）。。。　！　m(_ _)m
（隠居じーさん） 2019/10/08(火) 21:25

 隠居じーさん　さん

 こんばんは！

 いつもありがとうございます。

 奥さんにいつも「やかましい！！！」って怒られてます(笑)

 だって、、調子がでないんですもの(^^;

 これからもよろしくお願いいたします。。。。。
（SoulMan） 2019/10/08(火) 21:32

 SoulMan　さんへ　
家はもう奥さんに無視されてます（笑）
こちらこそ、今後とも、宜しくお願い致します。。。。m(_ _)m
ぬまる猫　さん　横入り。すみません
（隠居じーさん） 2019/10/08(火) 21:58

 こんにちは　＾＾　
ダミ－情報、こさえてみました。御不用でしたら、無視してくださいませ。＾＾；
今回は何回作成しても同じものが出来るようにしました。←　あたりまえだろ（笑）
もしお使いでしたら、シート名とか、表示位置は既存の物に合わせ変えて下さい。
アップしてませんが、私の作成したコードでは２０数分かかります。←駄作に付き
恥ずかしくてアップ出来ません。作成件数等、てきとぉ～に増減すればテスト用に
は使えなくは無いかもです。(#^^#)。。。内容は。。。ぬまる猫さん　にしかられ
そぉですね。。。でわでわ　　　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 。。。
かえって、混乱させていないか、心配です（あり得ない情報だったりして。。。＾＾；）
↑　にもかかわらず、テストを賜り、恐縮です。いま　ZzzzＺＺＺ。。状態ですので
とりあえず、お礼と、お詫びまで。SoulManさん、すみません　m(_ _)m
あれこれ試しているのですが私自身が　←　混乱状態です　(◎_◎;)
（笑）また、明日、以降、整理して、SoulMan　さんのコードを頼りに勉強してみます。
配列、万歳。。。　(#^^#)ｖ
でわでわ、ありがとうございました。
（隠居じーさん） 2019/10/09(水) 22:49

 隠居じーさん さん

 こんばんは！

 私はいつも学校でコードを書いてますが、あくまでサンプルだと思ってます。

 実際の作業に応用する際には、すんなりと行かないものだと思ってます。

 そこを応用していただければ、、と思ってます。。

 隠居じーさん さんのサンプルコードは大変助かりました。

 本当にありがとうございます。m(__)m

 これからもどうぞよろしくお願いいたします。

 では、、では、、また、、、
（SoulMan） 2019/10/09(水) 22:58

 おはようございます。　＾＾
そぉ～おっしゃっていただければ、幸甚です。
でわ、また、、m(_ _)m
（隠居じーさん） 2019/10/10(木) 07:24

コメント返信：

[ 一覧(最新更新順) ]

[[20190918140726]] 『ややこしい比較』（ぬまる猫） ページの最後に飛ぶ

[[20190918140726]]　『ややこしい比較』（ぬまる猫）　ページの最後に飛ぶ