Results of 1 - 1 of about 19623 for 20�����������������������... (0.004 sec.)
- [[20160803170144]]
- #score: 2681
- @digest: 1753687479aeca47ff36011227895cfb
- @id: 71290
- @mdate: 2016-08-06T08:23:01Z
- @size: 39361
- @type: text/plain
- #keywords: 字違 (221367), countdiff (125474), 較文 (82783), 一歩 (24934), ウッ (24123), 歩） (19122), ッシ (16383), 不一 (15453), 60000 (13647), シさ (13308), 相違 (9608), timer (9255), 2016 (8559), 文字 (8414), 個以 (8060), 比較 (6122), 字列 (5688), cnt (4566), 木) (3638), 件数 (3538), 一致 (3367), dic (3221), 違い (3184), mid (2818), long (2534), function (2487), 時間 (2444), 金) (2413), 処理 (2384), range (2305), の一 (2170), ）20 (2167)
- 『1文字だけ異なるセル数をカウント』（はじめの一歩）
20個のアルファベットからなる文字列が60000行あります。全く同じ文字列のセル数をCountifで数えるように、1文字だけ異なるセルの数や2文字だけ異なるセルの数を数える方法を教えてください。マクロを使う方法でも良いです。 よろしくお願いします。 ＜ 使用 Excel:Excel2016、使用 OS:Windows10 ＞ ---- 件数が件数だけに、どんなやりかたにしろ、それなりに処理時間はかかると思いますが 1文字だけ違う文字列の定義を教えて下さい。（わかりやすくするために 7桁で考えます） ABCDEFG ABXDEFG きっとこれは 1文字だけ違うんでしょうね。 では ABCDEFG XABCDEF こういうものは、1文字だけ違うとみなしますか? それとも全然異なるものとみなしますか? 同じかどうかの基準に位置も考慮すると、異なるものでしょうね。 位置は無視して、7文字中 ABCDEF の6文字は 順番も含めて一致していると考えれば 違っているのは1文字だけになりますね。 （β） 2016/08/03(水) 17:57 ---- お返事ありがとうございます。文字列の中の同じ位置の文字同士を比較して、違う文字が1つだけという意味です。ABCDEFGとBACDEFGは2文字違うとカウントしたいです。よろしくお願いします。 （はじめの一歩） 2016/08/03(水) 18:04 ---- こんにちは こんな感じでどうですか? Sub test() Dim r As Range Dim i As Long Dim j As Long Const 比較文字列 As String = "ABCDEFGHIJABCDEFGHIJ" 'データがA列にあるとしてB列を作業列、結果列として使用する With Range("A1", Range("A" & Rows.Count).End(xlUp)).Offset(, 1) .Formula = "=IF(A1=""" & 比較文字列 & ""","""",1)" .Value = .Value For Each r In .SpecialCells(xlCellTypeConstants) j = 0 For i = 1 To 20 If Mid(r.Offset(, -1), i, 1) <> Mid(比較文字列, i, 1) Then j = j + 1 '相違した文字を赤くする r.Offset(, -1).Characters(Start:=i, Length:=1).Font.ColorIndex = 3 End If Next r = j Next End With End Sub （ウッシ） 2016/08/04(木) 08:25 ---- 追記 大文字、小文字区別するなら、数式セットの部分を下記コードに差し替えて下さい。 .Formula = "=IF(EXACT(A1,""" & 比較文字列 & """)=TRUE,"""",1)" （ウッシ） 2016/08/04(木) 08:36 ---- ウッシさんの方法、わかりやすくていいですね。 結果も視覚的に把握しやすいですし。 ただ、さすがに 6万件だと、重い処理コストの文字ごとの色塗りの負荷が高くなりすぎて 処理時間が、ちょっと待ちきれない長さになると思われます。 なので、ウッシさんのコードを借用し、視覚的なわかりやすさを割愛して、単に相違文字数のカウントのみを加えてみました。 以下の TestGen で 6万件の文字列を生成し、それに対して実行させます。 相違文字数の取得までに、私の環境では 2秒前後かかってしまいますが。 Sub Test2() Dim r As Range Dim i As Long Dim j As Long Const 比較文字列 As String = "ABCDEFGHIJABCDEFGHIJ" Dim dic As Object Dim n As Long Set dic = CreateObject("Scripting.Dictionary") For Each r In Range("A1", Range("A" & Rows.Count).End(xlUp)) If r.Value <> 比較文字列 Then j = 0 For i = 1 To 20 If Mid(r, i, 1) <> Mid(比較文字列, i, 1) Then j = j + 1 End If Next dic(j) = dic(j) + 1 End If Next 'ここから相違文字のカウント表示 n = CountDiff(dic, 1) MsgBox "1:" & n n = CountDiff(dic, 2) MsgBox "2:" & n n = CountDiff(dic, 17) MsgBox "17:" & n End Sub Function CountDiff(dic As Object, n As Long) As Long If dic.exists(n) Then CountDiff = dic(n) End Function （β） 2016/08/04(木) 09:12 ---- ↑ もし、実際のデータで指定文字列と、全く同じものが、相当数存在するということであれば 検索対象を、ウッシさんのオリジナルコードのように、SpecialCellsで絞り込むほうが効率はよくなると思います。 （β） 2016/08/04(木) 09:18 ---- TestGen コードのアップを失念していました。 Sub TestGen() Dim x As Long Dim y As Long Dim s As String * 20 ReDim v(1 To 60000, 1 To 1) For y = 1 To UBound(v, 1) For x = 1 To 20 Mid(s, x, 1) = Chr(65 + Int(26 * Rnd + 1) - 1) Next v(y, 1) = s Next Range("A1").Resize(UBound(v, 1)).Value = v End Sub （β） 2016/08/04(木) 09:21 ---- ウッシさん、βさん、早速マクロを考案していただき、ありがとうございます。 結論から申し上げますと、まだ私の説明不足で、私の欲しい結果は得られませんでした。 私の目的をもう一度ご説明する前に、ウッシさんとβさんのマクロを用いて行ったテストの結果をご報告します。 アルファベット20文字の文字列100行で試したところ、ウッシさんのマクロは（ウッシさんの意図どおりに?）検索文字列"ABCDEFGHIJABCDEFGHIJ”と違う文字を赤字にし、B列に検索文字列と違う文字の数を返しました。 βさんのマクロはそのままコピペしたら、20行目のCountDiffのところで、”コンパイルエラー SubまたはFunctionが定義されていません”と表示されて停止しました。マクロは初歩的なものを扱ったことがあるだけなので勘違いしているかもしれませんが、TestGen ()というマクロはアルファベット20文字の文字列60000行のサンプルを作成する目的のものだと考え、実際に調べたい文字列のリストは手元にありますので使用していません。 私の目的は以下の通りです。私の手元にC1からC60000までの範囲にATGCの四つのアルファベットがランダムに20個並んだ文字列のリストがあります。そこで、D1にはC1からC60000までの範囲にC1と1文字違う文字列が何個あるか、D2にはC1からC60000までの範囲にC2と1文字違う文字列が何個あるか、以下同様にセルDnにC1からC60000までの範囲にCnの文字列と1文字違う文字列が何個あるかを返してほしいのです。Countifで全く同じ文字列を数えるように、1文字違いの文字列を数えたいと書いたのはこのような意味です。 さらに、E列には同様に2文字違う文字列の数を返すようにしようと考えています。ですので、マクロのどこで違う文字の数を規定しているのかもお教えいただけると幸いです。 説明不足で申し訳ありません。よろしくお願いいたします。 （はじめの一歩） 2016/08/04(木) 11:13 ---- >>βさんのマクロはそのままコピペしたら、20行目のCountDiffのところで、”コンパイルエラー Subまたは >>Functionが定義されていません”と表示されて停止しました Function CountDiff(dic As Object, n As Long) As Long If dic.exists(n) Then CountDiff = dic(n) End Function このコードも一緒に貼り付けていますか? （β） 2016/08/04(木) 12:37 ---- βさん、ご指摘有難うございます。今度はFunction CountDiff以下の3行も一緒にコピペしました。するとEnd Subの下に線の区切りが入って、Function CountDiff以下の3行が挿入されました。その状態でマクロを実行したところ、 Microsoft Excel 1:0 というウインドウが表示され、OKをクリックすると Microsoft Excel 2:0 というウインドウが表示され、さらにOKをクリックすると Microsoft Excel 17:150 というウインドウが表示され、OKをクリックすると何も起こらずにマクロが終了しました。 （はじめの一歩） 2016/08/04(木) 13:15 ---- こんにちは 遺伝子情報の塩基配列のチェック? 60000件が全て違うとすると、1件に付き20桁調べる作業を、60000件毎に行う。 最大720億回ちょいマイナス回のチェック? 相当時間掛かりますけど、いいのでしょうか? （ウッシ） 2016/08/04(木) 14:17 ---- >>Microsoft Excel >>1:0 >>というウインドウが表示され、OKをクリックすると はい。それで正常です。 私のコードでは、ウッシさんのアイデアの処理ロジックを拝借して、1文字違っている件数、2文字違っている件数、3文字違っている件数、・・・・ を Dictionary という入れ物にいれ、そのあと、 n = CountDiff(dic, 異なる文字数) と記述することで、n に、それが何件だったかを取得し、その結果を MsgBox n で表示しています。 アップしたサンプルでは 1文字異なるケース、2文字異なるケース、17文字異なるケースを表示しています。 1:0 あるいは 2:0とでているのは 1文字だけ違う文字列や2文字だけ違う文字列は、なかったよということです。 17:150 は、20桁の文字列の中で 17桁異なっているもの（いいかえると 3桁が同じだったもの）が 150件ありましたということです。 つまり ●文字違っている件数を取得するには n = CountDiff(dic, ●) と書きます。 （β） 2016/08/04(木) 15:01 ---- いずれにしても、これら60000件のデータで、いつ、何をしたいのかがカギでしょうね。 私がアップしたものは、あくまで、サンプルです。 実際に、はじめの一歩さんが、いつ、どういう情報を抜き出したいかによって、アップしたサンプルを たとえば分解して、複数のプロシジャにわけておくということも必要になるかもしれません。 また、一覧で、どこかに表示させたいということなら、そのように組み変えることが必要です。 （たいした組み変え作業ではないです） （β） 2016/08/04(木) 15:09 ---- たとえば以下は、B1 に 比較したい20桁の文字列をいれておいて、それをA列と比較。 D列に異なる文字数、E列に、その件数を列挙します。 実際に現れた結果だけを表示しています。たとえば 3文字異なるものがなければ、3 は 0 という表示はしていません。 0〜20 まですべてリストさせたい（なかったものは 0 として）ということも、もちろんできますが。 あとは、このデータを元に、シート上で関数処理をするなり、なんなり 好きなように使ってください。 なお、今回は、この Test3 だけで処理します。 Sub Test3() Dim s As String Dim r As Range Dim i As Long Dim j As Long s = Range("B1").Value With CreateObject("Scripting.Dictionary") For Each r In Range("A1", Range("A" & Rows.Count).End(xlUp)) If r.Value <> s Then j = 0 For i = 1 To 20 If Mid(r, i, 1) <> Mid(s, i, 1) Then j = j + 1 End If Next .Item(j) = .Item(j) + 1 End If Next Columns("D:E").ClearContents Range("D1").Resize(.Count).Value = WorksheetFunction.Transpose(.keys) Range("E1").Resize(.Count).Value = WorksheetFunction.Transpose(.items) Range("D1", Range("D" & Rows.Count).End(xlUp)).Resize(, 2).Sort key1:=Columns("D"), Order1:=xlAscending End With End Sub （β） 2016/08/04(木) 15:44 ---- βさん、すいません、 2016/08/04(木) 15:09のコメントに対するお返事を書いていたら、次のコメントをいただいてしまいました。 とりあえず、2016/08/04(木) 15:09のコメントに対するお返事を書きます。 2016/08/04(木) 15:44のコメントに対するお返事は後ほど。 ------ βさん、なるほどそういうことだったのですね。 私の目的のかなり近いとこまで来ているのですね。実際には特定の比較文字列があるのではなく、リストに含まれる20文字の文字列1つ一つに対し、リスト中に1文字違いの文字列がいくつあるか、2文字違いの文字列がいくつあるかを各文字列の右隣のセルに書き出したいのです。 文字列のリスト 1文字違い 2文字違い GTCGCTGAGCTCCGATTCGA 0 0 ACCTGTAGTTGCCGGCGTGC 0 1 CGTCAGCGTCACATTGGCCA 0 0 CGCGCACTGGTCCAGCGCAC 0 0 : : といった感じです。 βさんのマクロで、検索文字列を特定の文字列ではなくリスト中の各文字列を参照するようにして、結果を各文字列の右隣に書き出すようにしていただければ良いのではないかと思いますが、初心者のためそのやり方が分かりません。恐縮ですが、やり方をご指導いただければ幸いです。 目的はリスト中に、1文字違いや2文字違いは含まれていないことを確かめたいのです。結果はどこかに表示したいわけではありませんが、記録として上記のようなエクセルの表としてファイルの形で保存します。ある実験の解析法を考える際にこの情報が必要となり、結果は出来るだけ早くほしいです。 よろしくお願いします。 （はじめの一歩） 2016/08/04(木) 16:34 ---- であれば私がアップした Test3 をちょこっと変更するとお望みのものができます。 しばしお待ちください。 ★ただし、ウッシさん指摘の通り、データ件数がデータ件数ですから、気が狂うほど 処理時間は長くなる予感がします。 ★追記 16:49 私がアップした Test3 ではなく、すでにウッシさんから出ているコードを ベースにしたほうがよさそうです。 （β） 2016/08/04(木) 16:46 ---- βさん、Test3をさらに改良していただけるとのこと、ありがとうございます。 できれば、必要に応じて3文字違い、4文字違いの列も作れるように、その際に追加するスクリプトもご指導いただければ幸いです。 （はじめの一歩） 2016/08/04(木) 16:57 ---- こんにちは βさんのお借りすると、 Sub Test1() Dim r As Range Dim dic As Object For Each r In Range("C1", Range("C" & Rows.Count).End(xlUp)) Set dic = CreateObject("Scripting.Dictionary") Call Test2(dic, r.Value) r.Offset(, 1).Resize(, 20).Value = _ WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items)) dic.RemoveAll Next End Sub Sub Test2(dic As Object, 比較文字列 As String) Dim r As Range Dim i As Long Dim j As Long Dim n As Long For Each r In Range("C1", Range("C" & Rows.Count).End(xlUp)) If r.Value <> 比較文字列 Then j = 0 For i = 1 To 20 If Mid(r, i, 1) <> Mid(比較文字列, i, 1) Then j = j + 1 End If Next dic(j) = dic(j) + 1 End If Next End Sub Function CountDiff(dic As Object, n As Long) As Long If dic.exists(n) Then CountDiff = dic(n) End Function こんな感じかと。 私のだと、 Sub test() Dim r As Range Dim t As Range Dim s As Range Dim w As Range Dim i As Long Dim j As Long Dim v(1 To 1, 1 To 20) Set t = Range("C1", Range("C" & Rows.Count).End(xlUp)) For Each s In t 'データがC列にあるとしてB列を作業列、結果列として使用する With t.Offset(, -1) .Formula = "=IF(C1=""" & s.Value & ""","""",1)" .Value = .Value On Error Resume Next Set w = .SpecialCells(xlCellTypeConstants) On Error GoTo 0 If Not w Is Nothing Then For Each r In w j = 0 For i = 1 To 20 If Mid(r.Offset(, -1), i, 1) <> Mid(s.Value, i, 1) Then j = j + 1 End If Next v(1, j) = v(1, j) + 1 Next End If End With s.Offset(, 1).Resize(, 20) = v Erase v Next End Sub どちらにしても、非常に時間が掛かると思いますし、最後まで終了するかどうか・・・ （ウッシ） 2016/08/04(木) 17:03 ---- 私も、今ちょこっと書き上げて流しています。 最初は 100行ほどのデータで実行。すぐに終わりましたので、今度は 60000行にしたものを相手に実行中。 しかし、ウッシさん指摘の通り720億回の処理ですから、明日の朝までに終わるかどうか・・・ （β） 2016/08/04(木) 17:17 ---- ウッシさん、ありがとうございます。早速999行のリストで試してみました。 1つ目のマクロだと文字列の右に20列の答えを返してきました。左から20字違い、19字違い...で、一番右が1字違いの数という理解でよろしいでしょうか。 999行で24秒程度でしたので、60000行だと24時間ぐらいかかりそうです。1字違いから4字違いまでの4列に絞るとかしたいのですが、どこをどのように変えたら良いでしょうか。 また、1字違いなど、結果が0個の場合0ではなく、#N/Aが帰ってきますが、0にするにはどうしたらよいでしょうか。 2つ目のマクロは全ての行に対しC列から20列右のWの列に998という数字が帰ってきました。D列からV列(C列の右1から19列目)までは空欄のままでした。 βさん、60000行で試行していただいているとのこと、ありがとうございます。楽しみに待っています。 （はじめの一歩） 2016/08/04(木) 17:53 ---- ウッシさん、先ほどは気が付かなかったのですが、2つ目のマクロでは、B列の1行目から998行目にも1という数字を返してきました。 （はじめの一歩） 2016/08/04(木) 19:53 ---- 60000件で流していた処理ですが、時間がかかるというより、エクセル自体が固まってしまっているような感じなので 1時間半経過した時点で、強制終了させました。 同じような処理をループ内で繰り返すと、エクセルがハングアップしてしまうケースがありますけど、 その状況かも。 なので、1件を元にほかの文字列と比較する、その単位で、DoEvents を挟んで、もう一度やってみます。 とりあえず、1000件で処理すると 5秒ですから、60000件だと・・・理論的には5時間で終わるはず。 さて、どうなりますか。 （β） 2016/08/04(木) 20:14 ---- ウッシさん、1つ目のマクロについてC列に下記の20行の文字列を入れて試してみました。 GTCGCTGAGCTCCGATTCGA ACCTGTAGTTGCCGGCGTGC CGTCAGCGTCACATTGGCCA CGCGCACTGGTCCAGCGCAC CCAAGCTATATCCTGTGCGC AAGTTGCTTGATTGCATTCT CGCTTCTTAAATTCTTGGGT TCACAGCGAAGGCGACACAG CAAACTCCTTCATCCAAGTC AAATTTCCCCTCCGTTCAGA GCTTACCTGTAGTTCCACCA TATTTCCAACTCCCGACACC CGAATGCGCGTCGCGTTCGA CTTCGAACGCGACGCGCATT CGGCAGATCCTACTTACACT CAGTCCCGCTACGTCCTCAA CTACTGCCCCACGACGCACG CTTTGAGGACATCAACCCCG CAGCTCGGATGCATCCCGCC GTAGCGCCTCCACTCTCGAT すると、一行目文字列についてD1からW1のセルに2,3,1,3,3,3,1,3,0,0,0,0,0,0,0,0,0,0,0,0という数字を返してきました。 左から20字違い、19字違い...で最後が1字違いの文字列の数だと思ったのですが、ウッシさんが最初に作ってくれた違う文字を赤くしてくれるマクロで検証したところ、1行目の文字列を比較文字列とすると、20字違い、19字違いの文字列の数はどちらも0で、上記の結果と異なりました。その他の数字も一致しませんでした。 ということで、1つ目のマクロも何か問題がありそうです。 （はじめの一歩） 2016/08/04(木) 20:29 ---- βさん、エクセルがフリーズしてしまったとのこと、ご迷惑をおかけして申し訳ありません。 理論的には5時間で終わるというのは素晴らしいです。 申し訳ありませんが、よろしくお願いします。 （はじめの一歩） 2016/08/04(木) 20:32 ---- ウッシさん、1つ目のマクロについてもう少し調べてみたところ、数字の並び方の問題のようです。左から(あるいは右から）20字違い、19字違い...1字違いの文字列の数というような規則性のない、一見ランダムンな順番になっています。数字自体は上記のどれかの数に当てはまります。 （はじめの一歩） 2016/08/04(木) 21:14 ---- こんばんは 2つ目のマクロ、修正しました。 Sub test() Dim r As Range Dim t As Range Dim s As Range Dim w As Range Dim i As Long Dim j As Long Dim a As Single Dim v(1 To 1, 1 To 20) a = Timer Set t = Range("C1", Range("C" & Rows.Count).End(xlUp)) For Each s In t 'データがC列にあるとしてB列を作業列、結果列として使用する With t.Offset(, -1) .Formula = "=IF(C1=""" & s.Value & ""","""",1)" .Value = .Value On Error Resume Next Set w = .SpecialCells(xlCellTypeConstants) On Error GoTo 0 If Not w Is Nothing Then For Each r In w j = 0 For i = 1 To 20 If Mid(r.Offset(, 1), i, 1) <> Mid(s.Value, i, 1) Then j = j + 1 End If Next If j > 0 Then v(1, j) = v(1, j) + 1 End If Next End If End With s.Offset(, 1).Resize(, 20) = v Erase v Next t.Offset(, -1).ClearContents Debug.Print Timer - a End Sub 古いVISTAのPCで、（はじめの一歩） 2016/08/04(木) 20:29のデータで、0.4765625 秒でした。 単純に3000倍の時間では終わらないような気がします。 多分、PCの性能に大きく左右されるかも? 等比級数的に遅くなって、フリーズする感じがします。 （ウッシ） 2016/08/04(木) 23:07 ---- こんばんは 1つ目も修正しました。 こちらの方が速いと思います。 Sub Test1() Dim r As Range Dim a As Single Dim dic As Object a = Timer For Each r In Range("C1", Range("C" & Rows.Count).End(xlUp)) Set dic = CreateObject("Scripting.Dictionary") Call Test2(dic, r.Value) r.Offset(, 1).Resize(, 20).Value = _ WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.items)) dic.RemoveAll Next Debug.Print Timer - a End Sub Sub Test2(dic As Object, 比較文字列 As String) Dim r As Range Dim i As Long Dim j As Long Dim n As Long For Each r In Range("C1", Range("C" & Rows.Count).End(xlUp)) If r.Value <> 比較文字列 Then j = 0 For i = 1 To 20 If Mid(r, i, 1) <> Mid(比較文字列, i, 1) Then j = j + 1 End If Next For i = 1 To 20 dic(i) = IIf(i = j, dic(i) + 1, dic(i)) Next End If Next End Sub Function CountDiff(dic As Object, n As Long) As Long If dic.exists(n) Then CountDiff = dic(n) End Function （ウッシ） 2016/08/04(木) 23:17 ---- こんばんわ。 全て配列内だけで処理したらどうでしょうか? と言っても早いと言えるコードでは無いですけど、 （はじめの一歩） 2016/08/04(木) 20:29 の20件のデータで、 私のPCで、約0.008 秒でした。 この20件をコピペで1000件にして試したら、約2.4 秒でした。 因みに5000件にしたら、約62秒でした。 それ以上は試す根性が無いですけど、2乗倍に増えるとしたら、6万件で2時間半くらいになると思います。 これだけ時間のかかり処理でしたら、PCの性能次第で処理時間は大きく変わると思います。 1行目が項目行として2行目から検索しています。 データが1行目からでしたら、以下の C2 を C1 にして、 r = Range("C2", Range("C" & Rows.Count).End(xlUp)).Value 以下の D2:E を D1:E に変更して下さい。 Range("D2:E" & UBound(v, 1) + 1).Value = v Sub test() Dim r, r2, r3 Dim v() As Long Dim i As Long Dim j As Integer Dim cnt As Long Dim t As Double t = Timer r = Range("C2", Range("C" & Rows.Count).End(xlUp)).Value ReDim v(1 To UBound(r, 1), 1 To 2) For Each r2 In r i = i + 1 For Each r3 In r For j = 1 To 20 If Mid(r2, j, 1) <> Mid(r3, j, 1) Then cnt = cnt + 1 If cnt > 2 Then Exit For End If Next j Select Case cnt Case 1 v(i, 1) = v(i, 1) + 1 Case 2 v(i, 2) = v(i, 2) + 1 End Select cnt = 0 Next r3 Next r2 Range("D2:E" & UBound(v, 1) + 1).Value = v Debug.Print Timer - t End Sub （sy） 2016/08/05(金) 00:45 ---- 記述忘れすいません。 結果は1字違いの個数をD列、2字違いの個数をE列に表示させています。 （sy） 2016/08/05(金) 00:59 ---- 報告だけ。 まず、昨日から流していた処理、朝になっても終わっておらず、強制中断してチェックしますと 40000件のところでした。 そのあと、その時点から継続してみたんですが、同じコードを 1000件くらいでやると5秒で終わるものですけど、継続後は、 若干、時間が経過した時点で再中断したところ、40000件から動いていません。 (眠かったので、まったく動いていなかったのか、少しは処理したのかを確認するのを失念していました） 固まっていたのかもしれませんし、あるいは、ウッシさん指摘のように 等比級数的に遅くなっているのかもしれません。 いずれにしても、このままでは使えないですね。 で、気を取り直して、はじめの一歩さんが提示された20件のデータ、および 私のTestGenを少し変更して ATGC のみで 20桁の文字列を生成したものを1000件作成したもの、それぞれに対して、syさん、ウッシさん、および β（といっても、もともとのウッシさんのロジックを借用しているんですが）のコードで実行しています。 それぞれ、やっていることが少しずつ異なるので、単純比較はできないのですが、今のところ、私のものが一番、効率が悪いようです。 （なので、恥ずかしくてコードはアップしていません） ★ところで、syさんのコードですけど、2個の不一致が出たところで Exit For をしておられますね。 要件は 2個以上の不一致 ではなく 2個の不一致 ということではないでしょうか? （β） 2016/08/05(金) 06:48 ---- 私も参考出品してみます。 皆様のものと殆ど変わりはありませんが。 一応実行させてみたので、参考までに。 60000件の乱数データで実行したところ、 ・不一致文字数 1 2 3 4 ・データ数 0 5 51 661 となりました。（組み合わせ数。順序は問わず） 実行時間は、10530秒（約 2.9時間）でした。 # なお、こうした実行速度を求めるものにBasicは不適で、 # コンパイラ言語でやるのがいいんじゃないかと思ったり。 (ご参考) Sub test1() '乱数によるテストデータの作成 Dim j As Long Dim k As Long Const kosu As Long = 60000 Dim ATGC As Variant Dim s As String ATGC = Array("A", "T", "G", "C") For j = 1 To kosu s = String(20, "1") For k = 1 To 20 Mid(s, k, 1) = ATGC(Application.RandBetween(0, 3)) Next Sheet1.Cells(j, 1).Value = s Next End Sub Sub test2() Const kosu As Long = 60000 Dim s1 As String Dim s2 As String Dim j As Long Dim k As Long Dim n As Long Dim cnt As Long Dim p As Long Dim a(1 To 20) As String Dim tt Application.ScreenUpdating = False tt = Timer For j = 1 To kosu s1 = Sheet1.Cells(j, 1).Value '配列にしておいたほうが若干早い模様 For n = 1 To 20 a(n) = Mid(s1, n, 1) Next For k = j + 1 To kosu cnt = 0 s2 = Sheet1.Cells(k, 1).Value For n = 1 To 20 If Mid(s2, n, 1) <> a(n) Then cnt = cnt + 1 If cnt > 4 Then Exit For End If Next '不一致箇所が4個以下の組み合わせを別シートに書き出す If cnt <= 4 Then p = p + 1 Sheet3.Cells(p, 1).Resize(1, 3) = Array(cnt, j, k) End If Next Next Debug.Print Timer - tt Application.ScreenUpdating = True End Sub なお、結果（不一致文字が4以下のデータの、不一致文字数、対象行）は 別シートに書き出すだけにしています。 いかようにでも加工できます。 （γ） 2016/08/05(金) 06:52 ---- コメントしようとしていましたらγさんから、コードのアップがありました。 とりあえず、γさんのコードを試させていただいていない状況で書きこみを以下。 のちほど、γさんのコードも試してみます。 ざっとした感触ですけど、ウッシさんのコード、処理は一番早いように思います。 1000件で処理しますと、時間は、試しているものの中で、一番かかるのですが、これは、1行毎に結果を転記しておられることが原因で、 これを、最終配列を別に用意して、1行の結果を、その最終配列に格納しなおし、最後に1回、どさっと転記すれば 再格納の手間をいれても、処理時間は短くなると思います。 （β） 2016/08/05(金) 07:02 ---- こんにちは 配列で処理するように変更しました。 Sub test_2() Dim r As Range Dim t As Range Dim s As Range Dim w As Range Dim i As Long Dim j As Long Dim a As Single Dim e As Long Dim f As Long e = Range("C" & Rows.Count).End(xlUp).Row ReDim v(1 To e, 1 To 20) a = Timer Set t = Range("C1:C" & e) For Each s In t f = f + 1 For Each r In t If r <> s Then j = 0 For i = 1 To 20 If Mid(r.Offset(, 1), i, 1) <> Mid(s.Value, i, 1) Then j = j + 1 End If Next If j > 0 Then v(f, j) = v(f, j) + 1 End If End If Next Next Range("D1").Resize(e, 20) = v Erase v t.Offset(, -1).ClearContents Debug.Print Timer - a End Sub （ウッシ） 2016/08/05(金) 08:00 ---- こんにちは （はじめの一歩） 2016/08/04(木) 20:29 の20件のデータを6万件に拡張コピーした データで試すと、1件の処理に12秒掛りました。 12×60000÷60÷60=200 200時間掛ると思われます。 8年前のPCなので、最新の激速PCで試したら大幅に短縮出来るかも・・・ （ウッシ） 2016/08/05(金) 08:53 ---- To βさん ＞★ところで、syさんのコードですけど、2個の不一致が出たところで Exit For をしておられますね。 ＞要件は 2個以上の不一致 ではなく 2個の不一致 ということではないでしょうか? ん!? もしかして間違えたかなと思ったけど、、、 いえ、cnt>2 なので3文字以上不一致の時にロープを抜けるようになってます。 （sy） 2016/08/05(金) 10:33 ---- ウッシさん、βさん、syさん、γさん、有難うございます。朝、皆さんからのメッセージを見て感激しました。 早速、手元の999行のサンプルでテストしました。時間はストップウォッチで手動で計りましたので、正確ではありません。 ウッシさん2つ目のマクロ 8/4、23:07版 55秒、出力もOK ウッシさん1つ目マクロ 8/4、23:17版 38秒、出力もOK syさんマクロ 8/5、00:45版 1瞬(1秒以下?)、出力は1文字違いと2文字違いのみですがOK。 γさんのマクロ、8/5 6:52版 2秒、出力なし ウッシさん2つ目のマクロ配列処理 8/5 8:00版:53秒、W行にのみ998と出力、修正前と類似の問題。 γさんのマクロは999行のサンプルでテストするために、1行目をConst kosu As Long = 999に変更しましたが、何も出力されませんでした。念のためsheet3をあらかじめ作成しておいても、やはり出力されませんでした。 結果はsyさんのマクロが1文字違いと2文字違いのみの出力ながら最速でした。念のため、F行とG行にそれぞれ3文字違いと4文字違いを表示したいのですが、どこをどう変えたらよいか教えていただけないでしょうか。 （はじめの一歩） 2016/08/05(金) 10:56 ---- >>いえ、cnt>2 なので3文字以上不一致の時にロープを抜けるようになってます To syさん わぁ! 寝ぼけていました。ごめんなさい。 （β） 2016/08/05(金) 11:52 ---- Syさんのマクロで65394行の実際のデータを解析しました。 その結果、1時間以内に解析が終了し、(恐らく)正しい結果が得られました。 40分経っても1行も出力されていなかったので、仕事にメインで使っているコンピューターが使えないと困るので、サブのコンピューターで解析しようと準備していたら、54分経過したところで解析が終わっていました。 そのような訳で正確な所要時間は分かりませんが、999行で1秒という試行結果からほぼ予想通りの所要時間でした。 Syさん、もしよければ下記のお願いの件、よろしくお願いします。 ＞念のため、F行とG行にもそれぞれ3文字違いと4文字違いを表示したいのですが、どこをどう変えたらよいか教えていただけないでしょうか。 このデータはgRNAと呼ばれる短い人工遺伝子のライブラリーに含まれるgRNAの塩基配列のリストで、目的から考えて1文字(塩基)違いのgRNAは含まれないように設計されていると予想していたのですが、思った以上に相互に1文字(塩基)違いのgRNAが多数含まれていることが分かりました。お蔭さまで、今後の解析方法を考えるうえで大変参考になる情報が得られました。 皆さま、本当にありがとうございました。 （はじめの一歩） 2016/08/05(金) 13:04 ---- >念のため、F行とG行にもそれぞれ3文字違いと4文字違いを表示したいのですが syさんの素晴らしいプログラムに敬意を払いつつ修正版を書いてみました。 Sub test() Dim r, r2, r3 Dim v() As Long Dim i As Long Dim j As Integer Dim cnt As Long Dim t As Double t = Timer r = Range("C2", Range("C" & Rows.Count).End(xlUp)).Value ReDim v(1 To UBound(r, 1), 1 To 4) For Each r2 In r i = i + 1 For Each r3 In r For j = 1 To 20 If Mid(r2, j, 1) <> Mid(r3, j, 1) Then cnt = cnt + 1 If cnt > 4 Then Exit For End If Next j v(i, cnt) = v(i, cnt) + 1 cnt = 0 Next r3 Next r2 Range("D2:G" & UBound(v, 1) + 1).Value = v Debug.Print Timer - t End Sub （とおりすがり） 2016/08/05(金) 14:47 ---- とおりすがりさん、ありがとうございます。でも999行のサンプルで試したら、動きませんでした。 （はじめの一歩） 2016/08/05(金) 15:25 ---- > v(i, cnt) = v(i, cnt) + 1 if cnt<>0 then v(i, cnt) = v(i, cnt) + 1 end if でいかがでしょうか。 （とおりすがり） 2016/08/05(金) 16:08 ---- とおりすがりさん、 とおりすがりさんの修正版の v(i, cnt) = v(i, cnt) + 1 の1行を if cnt<>0 then v(i, cnt) = v(i, cnt) + 1 end if の3行と入れ替えて試しましたが、 実行時エラー'9': インデックスが有効範囲にありません。 とのメッセージが出ました。 （はじめの一歩） 2016/08/05(金) 17:56 ---- 度々失礼しました。 > if cnt<>0 then > v(i, cnt) = v(i, cnt) + 1 > end if if cnt>=1 and cnt<=4 then v(i, cnt) = v(i, cnt) + 1 end if （syさん、元コードを下手にいじっくてしまい申し訳ありませんでした。） 今度は大丈夫だとおもいます。 （とおりすがり） 2016/08/05(金) 18:58 ---- とおりすがりさん 今度はうまくいきました。有難うございました。 改めて、βさん、ウッシさん、syさん、γさん、とおりすがりさん、本当にありがとうございました。 βさん、PCをフリーズさせてしまって申し訳ありませんでした(泣)。 これほど皆さんが親身に助けてくれるとは思ってもいませんでした。 エクセルで困ったら、また質問させていただきます。 その際は、またよろしくお願いいたします。 （はじめの一歩） 2016/08/05(金) 20:52 ---- こんばんは 済みません、修正漏れでした。 2つ目のマクロ配列処理 8/5 8:00版 If Mid(r.Offset(, 1), i, 1) <> Mid(s.Value, i, 1) Then を If Mid(r.Value, i, 1) <> Mid(s.Value, i, 1) Then に差し替えて下さい。 20桁全ての不一致個数を数えるのと、1〜4個までの不一致個数を数えるのは 大幅に処理時間が違います。 どこまで必要なのですか? 本当は5個以上違うデータなのに4個までしか数えなくてもいいのならもっと時短出来ます。 （ウッシ） 2016/08/05(金) 20:56 ---- ウッシさん 2つ目のマクロ配列処理 8/5 8:00版の修正、ご教示いただき有難うございます。 何度か書きましたが、どうしても知りたかったのは1文字違いの数と2文字違いの数です。ただ、出来れは4文字違いくらいまでは調べたいと思っていました。 処理時間が短ければ20文字違いまで全て調べても良いわけですが、時間との兼ね合いで4文字違いくらいまでで充分かなと思っています。 （はじめの一歩） 2016/08/05(金) 23:09 ---- To とおりすがりさん 修正ありがとうございます。 昨日は歓迎会でカキコ出来なかったから助かりました。 後Select Caseで判定文字が増えたら長くなりすぎるなぁと思ってたけど頭が働かなかった部分が すごくすっきりになって感謝です。 （sy） 2016/08/06(土) 08:29 ---- こんにちは Sub test_3() Dim e As Long Dim a As Single Dim t As Variant Dim s As Variant Dim f As Long Dim r As Variant Dim j As Long Dim i As Long e = Range("C" & Rows.Count).End(xlUp).Row ReDim v(1 To e, 1 To 4) a = Timer t = Range("C1:C" & e).Value For Each s In t f = f + 1 For Each r In t If r <> s Then j = 0 For i = 1 To 20 If Mid(r, i, 1) <> Mid(s, i, 1) Then j = j + 1 If j = 4 Then Exit For End If Next If j > 0 Then v(f, j) = v(f, j) + 1 End If End If Next Next Range("D1").Resize(e, 4) = v Erase v Debug.Print Timer - a End Sub D〜F列に1〜3個違いのデータ数、G列に4個以上相違のデータ数を算出します。 （ウッシ） 2016/08/06(土) 08:50 ---- ウッシさん 2016/08/06(土) 08:50修正版のマクロありがとうございます。 早速試してみたのですが、G列に999とのみ表示され、DからF列までは空欄でした。 （ウッシ） 2016/08/05(金) 20:56のメッセージを参考に 19行目の If Mid(r, i, 1) <> Mid(s, i, 1) Then を If Mid(r.Value, i, 1) <> Mid(s.Value, i, 1) Then にしてみましたが、実行時エラー'424': オブジェクトが必要です。 と表示されました。 やはり、私のような素人がいじってもだめですね。 （はじめの一歩） 2016/08/06(土) 12:23 ---- γです。 動かなかったそうですが、私はA列にデータがある前提でコードを書いていました。 ちょっと中身を見て頂くとわかったのかもしれませんが。 でも、速度的には改善の余地があるものでした。 私の反省・感想メモ: (1)やはりシートアクセスの回数を極小化する配列利用が効果大きいことを改めて認識。 Mid関数どうしの比較を配列にする工夫（これ自体は効果あります）に気を遣うくらいなら もっと大事なところに気を遣うべきだった。 (2)不一致文字数の少ない、いわば低確率の事象の発生状態を調べるだけなら、 全データの結果は不要で、そうしたいわば例外的事象の結果だけ得られれば良い気がします。 そう考えれば、文字列Aと文字列Bを比較したあとで、もう一度、BとAを比較する 必要はないわけです。そう考えれば、実行時間は1/2になりますね。 私のコードはそのようにしています。 （γ） 2016/08/06(土) 12:37 ---- γさん コメントありがとうございます。 前回もA列のデータでも試したと思いますが、念のため再テストしましたが、残念ながら今回も何も書き出されずに終了してしまいました。 今回はA1からA1000までの1000行のデータで試しましたので、1行目は Const kosu As Long = 1000 に変更しました。 また、手元のデータを使用したので、乱数によるテストデータの作成は行わず、 Sub test2()のみ実行しました。 （はじめの一歩） 2016/08/06(土) 13:34 ---- こんにちは それは全てのデータが4個以上相違 しているという事では? （ウッシ） 2016/08/06(土) 14:38 ---- こんにちは GTCGCTGAGCTCCGATTCGA  GACGCTGAGCTCCGATTCGA  GAAGCTGAGCTCCGATTCGA  GTCGCTGAGCTCCGATAAAA  GTCGCTGAGCTCCGAAAAAA  をC1:C1000に入力して「Sub test_3()」を試すと、 C D E F G GTCGCTGAGCTCCGATTCGA 200 200 200 200 GACGCTGAGCTCCGATTCGA 400 400 GAAGCTGAGCTCCGATTCGA 200 200 400 GTCGCTGAGCTCCGATAAAA 200 200 400 GTCGCTGAGCTCCGAAAAAA 200 600 ・・・・ となると思います。 G列は4個以上相違データの件数です。 5個以上相違のデータ件数加算しなくて良ければ、 Sub test_4() Dim r As Variant Dim t As Variant Dim w As Range Dim i As Long Dim j As Long Dim a As Single Dim e As Long Dim f As Long Dim s As Variant Dim v As Variant e = Range("C" & Rows.Count).End(xlUp).Row ReDim v(1 To e, 1 To 4) a = Timer t = Range("C1:C" & e).Value For Each s In t f = f + 1 For Each r In t If r <> s Then j = 0 For i = 1 To 20 If Mid(r, i, 1) <> Mid(s, i, 1) Then j = j + 1 If j > 4 Then Exit For End If Next If j > 0 And j < 5 Then v(f, j) = v(f, j) + 1 End If End If Next Next Range("D1").Resize(e, 4).Value = v Erase v Debug.Print Timer - a End Sub こちらで。 C D E F G GTCGCTGAGCTCCGATTCGA 200 200 200 200 GACGCTGAGCTCCGATTCGA 400 200 GAAGCTGAGCTCCGATTCGA 200 200 GTCGCTGAGCTCCGATAAAA 200 200 200 GTCGCTGAGCTCCGAAAAAA 200 200 ・・・・ となります。 （ウッシ） 2016/08/06(土) 16:21 ---- ウッシさん ＞それは全てのデータが4個以上相違しているという事では? そうではありません。ウッシさんやsyさんのマクロで1字違い、2字違い、3字違いとも複数含まれていることが分かっているデータのセットです。この判定が誤りでないことは、ヒットした配列を直接見て確認しています。 （はじめの一歩） 2016/08/06(土) 16:42 ---- ウッシさん すいません。よく見たらちゃんとカウントしてくれていました。 G列の上位の方に、軒並み999と出たので勘違いしてしまいました。 1-3文字違いの行にはちゃんと数が表示されていました。 申し訳ありませんでした。 （はじめの一歩） 2016/08/06(土) 16:55 ---- 僭越ながら、ウッシさんの2016/08/06(土) 16:21のSub test_4() とsyさんのマクロをとおりすがりさんが4文字違いまで表示してくれるようにしてくれたものの処理速度を5000行のリストで比較したところ、なんと両方とも25秒でほぼ同タイムでした。実験用の電子タイマーで計ったので、厳密ではありませんが、差があっても一秒以内です。 結果（1文字違いから4文字違いまでの数）も全く同じでした。 私の目的にはどちらも充分実用的な速さで、お蔭様で私の目的も果たせました。 改めて有難うございました。 （はじめの一歩） 2016/08/06(土) 17:23... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201608/20160803170144.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 96999 documents and 607827 words.
訪問者：