[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『1文字だけ異なるセル数をカウント』（はじめの一歩）
20個のアルファベットからなる文字列が60000行あります。全く同じ文字列のセル数をCountifで数えるように、1文字だけ異なるセルの数や2文字だけ異なるセルの数を数える方法を教えてください。マクロを使う方法でも良いです。
よろしくお願いします。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
件数が件数だけに、どんなやりかたにしろ、それなりに処理時間はかかると思いますが １文字だけ違う文字列の定義を教えて下さい。（わかりやすくするために 7桁で考えます）
ABCDEFG ABXDEFG
きっとこれは １文字だけ違うんでしょうね。
では
ABCDEFG XABCDEF
こういうものは、１文字だけ違うとみなしますか？ それとも全然異なるものとみなしますか？ 同じかどうかの基準に位置も考慮すると、異なるものでしょうね。 位置は無視して、７文字中 ABCDEF の６文字は 順番も含めて一致していると考えれば 違っているのは１文字だけになりますね。
（β） 2016/08/03(水) 17:57
こんな感じでどうですか？
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
ウッシさんの方法、わかりやすくていいですね。 結果も視覚的に把握しやすいですし。 ただ、さすがに ６万件だと、重い処理コストの文字ごとの色塗りの負荷が高くなりすぎて 処理時間が、ちょっと待ちきれない長さになると思われます。
なので、ウッシさんのコードを借用し、視覚的なわかりやすさを割愛して、単に相違文字数のカウントのみを加えてみました。
以下の TestGen で ６万件の文字列を生成し、それに対して実行させます。 相違文字数の取得までに、私の環境では 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
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
βさん、なるほどそういうことだったのですね。
私の目的のかなり近いとこまで来ているのですね。実際には特定の比較文字列があるのではなく、リストに含まれる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
（はじめの一歩） 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
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
60000件で流していた処理ですが、時間がかかるというより、エクセル自体が固まってしまっているような感じなので 1時間半経過した時点で、強制終了させました。
同じような処理をループ内で繰り返すと、エクセルがハングアップしてしまうケースがありますけど、 その状況かも。
なので、１件を元にほかの文字列と比較する、その単位で、DoEvents を挟んで、もう一度やってみます。 とりあえず、1000件で処理すると 5秒ですから、60000件だと・・・理論的には5時間で終わるはず。 さて、どうなりますか。
（β） 2016/08/04(木) 20:14
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
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件から動いていません。 (眠かったので、まったく動いていなかったのか、少しは処理したのかを確認するのを失念していました）
固まっていたのかもしれませんし、あるいは、ウッシさん指摘のように 等比級数的に遅くなっているのかもしれません。
いずれにしても、このままでは使えないですね。
で、気を取り直して、はじめの一歩さんが提示された２０件のデータ、および 私のTestGenを少し変更して ATGC のみで 20桁の文字列を生成したものを１０００件作成したもの、それぞれに対して、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
コメントしようとしていましたらγさんから、コードのアップがありました。 とりあえず、γさんのコードを試させていただいていない状況で書きこみを以下。 のちほど、γさんのコードも試してみます。
ざっとした感触ですけど、ウッシさんのコード、処理は一番早いように思います。 １０００件で処理しますと、時間は、試しているものの中で、一番かかるのですが、これは、１行毎に結果を転記しておられることが原因で、 これを、最終配列を別に用意して、１行の結果を、その最終配列に格納しなおし、最後に１回、どさっと転記すれば 再格納の手間をいれても、処理時間は短くなると思います。
（β） 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
ウッシさん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
その結果、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
> 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行と入れ替えて試しましたが、
実行時エラー’９’：
インデックスが有効範囲にありません。
とのメッセージが出ました。
（はじめの一歩） 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
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
何度か書きましたが、どうしても知りたかったのは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/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
私の反省・感想メモ：
(1)やはりシートアクセスの回数を極小化する配列利用が効果大きいことを改めて認識。
Mid関数どうしの比較を配列にする工夫（これ自体は効果あります）に気を遣うくらいなら
もっと大事なところに気を遣うべきだった。
(2)不一致文字数の少ない、いわば低確率の事象の発生状態を調べるだけなら、
全データの結果は不要で、そうしたいわば例外的事象の結果だけ得られれば良い気がします。
そう考えれば、文字列Ａと文字列Ｂを比較したあとで、もう一度、ＢとＡを比較する
必要はないわけです。そう考えれば、実行時間は１／２になりますね。
私のコードはそのようにしています。
（γ） 2016/08/06(土) 12:37
今回はA1からA1000までの1000行のデータで試しましたので、1行目は
Const kosu As Long = 1000
に変更しました。
また、手元のデータを使用したので、乱数によるテストデータの作成は行わず、
Sub test2()のみ実行しました。
（はじめの一歩） 2016/08/06(土) 13:34
（ウッシ） 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
そうではありません。ウッシさんやsyさんのマクロで1字違い、2字違い、3字違いとも複数含まれていることが分かっているデータのセットです。この判定が誤りでないことは、ヒットした配列を直接見て確認しています。
（はじめの一歩） 2016/08/06(土) 16:42
すいません。よく見たらちゃんとカウントしてくれていました。
G列の上位の方に、軒並み999と出たので勘違いしてしまいました。
1-3文字違いの行にはちゃんと数が表示されていました。
申し訳ありませんでした。
（はじめの一歩） 2016/08/06(土) 16:55
結果（1文字違いから4文字違いまでの数）も全く同じでした。
私の目的にはどちらも充分実用的な速さで、お蔭様で私の目的も果たせました。
改めて有難うございました。
（はじめの一歩） 2016/08/06(土) 17:23
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.