全データの２割（同じ文字の内から）を抽出する方法

質問

Ａ表の全体数の２割分をＢ表にある同じ文字を抽出し、該当の文字を両方ともに色をつけたいです。

以下の表のように、別シートで２つあったとします。

全データから２割分だけをランダムに抽出し、その列に色をつける（できれば、横一列全てにマークをつけたいです。）
例えばＡ表の文字全てが、Ｂ表のＡ列にあるわけではありません。なので、該当するものからまた合計数の２割だけを選んでマークをつけたいです。ちなみにＡ表とＢ表共に。
黄色のマークは、同じ文字を含んでいるものだけにマークをつけています。

例の場合だと、10データあるので、その内の２割である２つにだけマークをつけたいです。
その２つは、必ずＢ表にもある同じ文字からに限る。

ちなみに実際のレポートでは、Ａ表が、3000ほどあり、Ｂ表には8000ほどデータがあります。Ａ表の3000の内の2割分に相当する600の文字でＡ表とＢ表ともに同じ文字の所に色をつけたいというのがしたい作業です。

ぜひ、ご教授いただけたら助かります。よろしくお願いいたします。

回答No.6

eden3616

>イミディエイトの欄にも、特に何も表示はでてきてないんですが・・・

イミディエイトにデバッグが表示されるよりも前の部分でエラーになっています。
イミディエイト何も出ていないという事は「Debug.Print ～～」の箇所よりも手前のコードで該当のエラーが発生しています。

>設定はできたのですが、「インデックスが有効範囲にありません」という文言が、
>マクロの実行を行ったらでてきました。

想定される上記エラー発生位置より、
設定したブック名またはシート名が誤っている可能性が高いと思います。

エラーメッセージの際、「デバッグ」をクリックしたときにエラー箇所が表示されます。
以下のどちらかでエラー（エラーになったコードの対象行が黄色く着色）になっていませんか？

Set tar_a(0) = Workbooks("対象ブック名.xlsm").Sheets("対象シート名")
Set tar_b(0) = Workbooks("対象ブック名.xlsm").Sheets("対象シート名")

該当部分の名称を修正願います。
エラー箇所が上記以外の場合、ご提示ください。

以下のマクロを実行してAlt+F11よりVBEを開いていただければ
イミディエイトウィンドウに現在選択されているセル範囲のブック名、シート名、セル範囲が表示されます。
A表、B表の表のセル範囲を選択した状態でマクロ「bookinfo」を実行してください。
イミディエイトの「→」より先の名称や範囲をVBAコード内の指定箇所の
ダブルクォーテーションマーク内「""」にコピーしてください。

Sub bookinfo()
Debug.Print "対象ブック名→" & ActiveWorkbook.Name
Debug.Print "対象シート名→" & ActiveSheet.Name
Debug.Print "対象セル範囲→" & Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False)
End Sub

>マクロ実行後は、何も入力等をしなくても集計等が行われるんでしょうか？？？

はい。設定に問題が無ければマクロを実行で処理の後に背景色がA表、B表ともに着色されます。

テスト用のファイルをアップロードしましたので参考にしてください。
https://www.dropbox.com/s/9zivhw0ydduhg76/%E5%AF%BE%E8%B1%A1%E3%83%96%E3%83%83%E3%82%AF%E5%90%8D.xlsm

お礼

本当に色々ありがとうございます。
また週明けにでも一連の作業をしてみたいと思います♪またご報告させていただきます。
取り急ぎ、お礼まで

補足

作業行ってみたのですが、やはりご指摘通り以下の箇所でエラーの黄色がでていました。
しかしながら、入力に間違いはないと思うのですが、どうやって間違いを見つけたらいいんでしょうか？

Set tar_a(0) = Workbooks("2013年下期(作業用)別.xls").Sheets("TA")
Set tar_b(0) = Workbooks("2013年下期(作業用)別.xls").Sheets("TB")

Bのやつは色が付かなかったので大丈夫かと思うのですが、Ａの方だけ何故か色がつきました。
初歩的な事ばかりでご迷惑をお掛けして、すみません。

回答No.5

eden3616

VBAコード変更しましたので最下のコードと全て入れ替えてください。

(1)A・B共通の文字列リストを作り
(2)ランダムで並び替え
(3)A表総数の２割の数だけ先頭からピックアップしています

>使い方がイマイチよく分からないのですが・・・
>1)ALT+F11　で画面をだし、
>2)VBA projectの画面に貼り付け
>3)Xでエクセルの画面に戻る

コードの貼付方は記載の手順で合っています。
コードの貼付先のブックは新規ブックを作成して貼り付けて頂いても、
A表またはB表のブックに張り付けて頂いても問題ありません。

>（Workbooksでブック名～～～～略
>これはどこにありますか？？？

VBAコード内の以下の部分を設定してください（添付画像参照）。
https://dl.dropboxusercontent.com/u/54799279/setumei.jpg
（画像が見えづらい場合はこちらを参照ください）
'-----------------------------------------
'◇表Aの範囲設定
' A表の対象ブック名および対象シート名の設定
Set tar_a(0) = Workbooks("対象ブック名.xlsm").Sheets("対象シート名")
' A表のセル範囲
Set tar_a(1) = tar_a(0).Range("A4:A8")

'◇表Bの範囲設定
' B表の対象ブック名および対象シート名の設定
Set tar_b(0) = Workbooks("対象ブック名.xlsm").Sheets("対象シート名")
' B表のセル範囲
Set tar_b(1) = tar_b(0).Range("A13:A17")
'-----------------------------------------
ダブルクォーテーションマーク「""」で括っている中身をご利用の環境に合わせて
『（半角全角注意して）一字一句間違わないように』修正してください。
同じブック・同じシートでも、別のブック・別のシートでも上記設定により指定可能です。
セル範囲は表の範囲のみを厳密に指定してください。
余計なセルを含むと数のカウント（2割計算）に影響します。

また、現在コードに記述してある設定は添付画像の場合の設定例となります。

>「action」はどのように実行したらいいのでしょうか？

エクセルメニューの「表示」→「マクロ」と辿り、
一覧より「action」を選択して「実行」してください。

■VBAコード

Option Explicit

Sub action()
Dim tar_a(2) As Object, tar_b(2) As Object
Dim i As Long, hword(2) As Long, cnt As Long, lmax As Long
Dim myAry1(), myAry2()
Dim tar As Object
'-----------------------------------------
'◇表Aの範囲設定
' A表の対象ブック名および対象シート名の設定
Set tar_a(0) = Workbooks("対象ブック名.xlsm").Sheets("対象シート名")
' A表のセル範囲
Set tar_a(1) = tar_a(0).Range("A4:A8")

'◇表Bの範囲設定
' B表の対象ブック名および対象シート名の設定
Set tar_b(0) = Workbooks("対象ブック名.xlsm").Sheets("対象シート名")
' B表のセル範囲
Set tar_b(1) = tar_b(0).Range("A13:A17")
'-----------------------------------------
tar_a(0).Range(tar_a(1).Cells(1, 1).Row & ":" & tar_a(1).Cells(tar_a(1).Rows.Count, 1).Row).Interior.ColorIndex = xlColorIndexNone
tar_b(0).Range(tar_b(1).Cells(1, 1).Row & ":" & tar_b(1).Cells(tar_b(1).Rows.Count, 1).Row).Interior.ColorIndex = xlColorIndexNone
ReDim myAry1(tar_a(1).Rows.Count, 2)
For i = 1 To tar_a(1).Rows.Count
If hit(tar_a(1).Cells(i, 1), tar_b(1)) > 0 Then
myAry1(cnt, 0) = tar_a(1).Cells(i, 1)
myAry1(cnt, 1) = Rnd
cnt = cnt + 1
Debug.Print cnt & "|" & myAry1(cnt - 1, 0) & " , " & myAry1(cnt - 1, 1)
End If
Next i
Call QuickSort(myAry1, LBound(myAry1), UBound(myAry1), 1)
Debug.Print "---------- cnt = " & cnt
For i = 1 + tar_a(1).Rows.Count - cnt To UBound(myAry1)
Debug.Print i & "|" & myAry1(i, 0) & " , " & myAry1(i, 1)
Next i
Debug.Print "x0.2cnt = " & WorksheetFunction.Round(tar_a(1).Rows.Count * 0.2, 0)
lmax = tar_a(1).Rows.Count - cnt + WorksheetFunction.Round(tar_a(1).Rows.Count * 0.2, 0)
If lmax > cnt Then lmax = tar_a(1).Rows.Count - cnt + cnt
Debug.Print "For i=" & 1 + tar_a(1).Rows.Count - cnt & " to " & lmax
For i = 1 + tar_a(1).Rows.Count - cnt To lmax
Debug.Print i & "|" & myAry1(i, 0)
hword(0) = hit(CStr(myAry1(i, 0)), tar_a(1))
hword(1) = hit(CStr(myAry1(i, 0)), tar_b(1))
If hword(1) > 0 Then
tar_a(0).Rows(tar_a(1).Cells(hword(0), 1).Row).Interior.Color = RGB(255, 255, 0)
tar_b(0).Rows(tar_b(1).Cells(hword(1), 1).Row).Interior.Color = RGB(255, 255, 0)
End If
Next i
End Sub

Function hit(word As String, tar As Object) As Long
On Error GoTo era
hit = WorksheetFunction.Match(word, tar, 0)
Exit Function
era:
hit = 0
End Function

Sub QuickSort(ByRef argAry() As Variant, ByVal lngMin As Long, ByVal lngMax As Long, ByVal keyPos As Long)
Dim i As Long
Dim j As Long
Dim k As Long
Dim vBase As Variant
Dim vSwap As Variant
vBase = argAry(Int((lngMin + lngMax) / 2), keyPos)
i = lngMin
j = lngMax
Do
Do While argAry(i, keyPos) < vBase
i = i + 1
Loop
Do While argAry(j, keyPos) > vBase
j = j - 1
Loop
If i >= j Then Exit Do
For k = LBound(argAry, 2) To UBound(argAry, 2)
vSwap = argAry(i, k)
argAry(i, k) = argAry(j, k)
argAry(j, k) = vSwap
Next
i = i + 1
j = j - 1
Loop
If (lngMin < i - 1) Then
Call QuickSort(argAry, lngMin, i - 1, keyPos)
End If
If (lngMax > j + 1) Then
Call QuickSort(argAry, j + 1, lngMax, keyPos)
End If
End Sub

補足

本当に丁寧で分かりやすい説明、有難うございました！！！
天才ですね～本当にこんなに出来る方が近くにいたら頼もしいですね。
やってみたのですが・・・

設定はできたのですが、「インデックスが有効範囲にありません」という文言が、マクロの実行を行ったらでてきました。
イミディエイトの欄にも、特に何も表示はでてきてないんですが・・・

マクロ実行後は、何も入力等をしなくても集計等が行われるんでしょうか？？？

回答No.4

eden3616

いくつか質問内容に疑問点があります。

>Ａ表の全体数の２割分をＢ表にある同じ文字を抽出し、該当の文字を両方ともに色をつけたいです。

この文面ですと以下のようなプロセスになるかと思います。
(1)A表のA列（4～n行）の2割の文字をランダム選出
(2)選出された文字をB表のA列（4～n行）より検索
(3)該当する行全体をA表、B表に着色

A表の2割の2行がB表になければ着色されないことになりますが
「A表の2割で共通する文字を着色」することが目的であれば問題になりませんか？

・共通する文字の中から共通する数の２割
・共通する文字の中から全体（A表）の数の２割
・２割のなかから共通する文字

によって意味合いや処理が異なります。

>全データから２割分だけをランダムに抽出し、
>その列に色をつける（できれば、横一列全てにマークをつけたいです。）

横一列とあるので「列に色」ではなく「行に色」ですよね？

>黄色のマークは、同じ文字を含んでいるものだけにマークをつけています。

添付画像の文字「F」について
A表「塗り着色無し」、B表「黄色着色」になっていますが。
また添付画像の着色については「全体の2割の共通する文字に着色」ではなく
「共通する文字列に着色」の状態であるように見受けられます。
これは説明用の画像であり、目的の形ではないと判断致します。

>10データあるので、その内の２割である２つにだけマークをつけたいです。
>Ａ表が、3000ほどあり、Ｂ表には8000ほどデータがあります。
>Ａ表の3000の内の2割分に相当する600の文字

上記文字「F」が着色漏れだとすると、
着色された7行分の2割＝1.4≒1行分（四捨五入？）ではなく、
全体（10行分）の2割＝2行分の「2割」ということでよろしいでしょうか？

>例えばＡ表の文字全てが、Ｂ表のＡ列にあるわけではありません。

この場合、A表の2割の数がA表・B表共通の文字数を超えてしまう可能性があります。
　→　文字がA表：A～J、B表：J～Sの連続アルファベットだった場合、
　　　A表10行の2割で2行分が対象となるが、共通の文字列がJの1行しかない。
その場合は全て共通する文字の行をマークすればいいということでしょうか？

■VBAコード
以下のコードを貼り付けて「表Aの範囲」と「表Bの範囲」を設定して「action」を実行してください。
（Workbooksでブック名、Sheetsでシート名、Rangeで表のセル範囲をそれぞれ指定）

Option Explicit

Sub action()
Dim tar_a(2) As Object, tar_b(2) As Object
Dim i As Long, hword(2) As Long
Dim myAry1(), myAry2()
Dim tar As Object
'-----------------------------------------
'表Aの範囲
Set tar_a(0) = Workbooks("Book1").Sheets("Sheet1")
Set tar_a(1) = tar_a(0).Range("A4:A13")
'表Bの範囲
Set tar_b(0) = Workbooks("Book2").Sheets("Sheet1")
Set tar_b(1) = tar_b(0).Range("A4:A13")
'-----------------------------------------
ReDim myAry1(tar_a(1).Rows.Count, 2)
For i = 1 To tar_a(1).Rows.Count
myAry1(i - 1, 0) = tar_a(1).Cells(i, 1)
myAry1(i - 1, 1) = Rnd
Next i
Call QuickSort(myAry1, LBound(myAry1), UBound(myAry1), 1)
ReDim myAry2(WorksheetFunction.Round(tar_a(1).Rows.Count * 0.2, 0) + 1)
For i = 2 To WorksheetFunction.Round(tar_a(1).Rows.Count * 0.2, 0) + 1
hword(0) = hit(CStr(myAry1(i - 1, 0)), tar_a(1))
hword(1) = hit(CStr(myAry1(i - 1, 0)), tar_b(1))
If hword(1) > 0 Then
tar_b(0).Rows(tar_b(1).Cells(hword(1), 1).Row).Interior.Color = RGB(255, 0, 0)
End If
Next i
End Sub

Function hit(word As String, tar As Object) As Long
On Error GoTo era
hit = WorksheetFunction.Match(word, tar, 0)
Exit Function
era:
hit = 0
End Function

Sub QuickSort(ByRef argAry() As Variant, ByVal lngMin As Long, ByVal lngMax As Long, ByVal keyPos As Long)
Dim i As Long
Dim j As Long
Dim k As Long
Dim vBase As Variant
Dim vSwap As Variant
vBase = argAry(Int((lngMin + lngMax) / 2), keyPos)
i = lngMin
j = lngMax
Do
Do While argAry(i, keyPos) < vBase
i = i + 1
Loop
Do While argAry(j, keyPos) > vBase
j = j - 1
Loop
If i >= j Then Exit Do
For k = LBound(argAry, 2) To UBound(argAry, 2)
vSwap = argAry(i, k)
argAry(i, k) = argAry(j, k)
argAry(j, k) = vSwap
Next
i = i + 1
j = j - 1
Loop
If (lngMin < i - 1) Then
Call QuickSort(argAry, lngMin, i - 1, keyPos)
End If
If (lngMax > j + 1) Then
Call QuickSort(argAry, j + 1, lngMax, keyPos)
End If
End Sub

補足

eden3616さん、私の説明不足で分かりにくい中、仕上げて下さって本当にありがとうございます！！
再度、以下に補足説明を書かせて頂きました。

>Ａ表の全体数の２割分をＢ表にある同じ文字を抽出し、該当の文字を両方ともに色をつけたいです。

この文面ですと以下のようなプロセスになるかと思います。
(1)A表のA列（4～n行）の2割の文字をランダム選出
----＞この２割は、Ａ列の総合計のセル数からになります。
　　　 しかし、色付けは、A表とB表の中で同じ文字の中から選出したいのですが・・・
　　　 例えばＡ表のＡ列の該当数が、6000あって、その中でＡ表とＢ表共に該当する文字が3200あった　　　 とすると、その3200ある内の中から1200（6000の２割）に色を付ける。Ａ表とＢ表共に。
　　　　（但し、Ａ表・Ｂ表共に総数も該当する数も異なります）
　　　 数の計算は、Ａ表からのみ行います。（こちらが正式な原本の表となる為）それが確実にあって
　　　 いるかをＢ表で確認するという作業になります。
(2)選出された文字をB表のA列（4～n行）より検索
(3)該当する行全体をA表、B表に着色

A表の2割の2行がB表になければ着色されないことになりますが
「A表の2割で共通する文字を着色」することが目的であれば問題になりませんか？
-----＞その色付けした表をそのまま提出して、Ａ表とＢ表に同じ文字があることを示さなければいけな
　　　　い為、両方の表に着色は必要になってくるのですが・・・

・共通する文字の中から共通する数の２割
・共通する文字の中から全体（A表）の数の２割-------＞▼数としてはこれが該当いたします。
・２割のなかから共通する文字

横一列とあるので「列に色」ではなく「行に色」ですよね？
-----＞すみません、「行」が正しいです。

>黄色のマークは、同じ文字を含んでいるものだけにマークをつけています。

添付画像の文字「F」について
A表「塗り着色無し」、B表「黄色着色」になっていますが。
-----＞塗り漏れていました。。。
　　　 しかしながら、同じ文字があってもＡ表・Ｂ表共に着色なしもあり得ます。それは、２割以上
　　　　該当する文字があった場合です。

記文字「F」が着色漏れだとすると、
着色された7行分の2割＝1.4≒1行分（四捨五入？）ではなく、
全体（10行分）の2割＝2行分の「2割」ということでよろしいでしょうか？
----＞全体の２割で、また該当する文字の中からその２割相当分の数を抽出したいです。
　　　小数点以下は、四捨五入でも切り捨てでも大丈夫です。

>例えばＡ表の文字全てが、Ｂ表のＡ列にあるわけではありません。

この場合、A表の2割の数がA表・B表共通の文字数を超えてしまう可能性があります。
　→　文字がA表：A～J、B表：J～Sの連続アルファベットだった場合、
　　　A表10行の2割で2行分が対象となるが、共通の文字列がJの1行しかない。
その場合は全て共通する文字の行をマークすればいいということでしょうか？
-----＞データ的には、必ずＢ表にも２割以上同じ文字があるというレポートになっています。もしない
　　　　場合は、Ｊの１行だけのマークで大丈夫です。

文字データは、「日付+人名+人数」で相当しております。

例
Ａ表　　　　　　　　　　　Ｂ表

「2013521タナカ1」●　 「2013521スズキ1」　
「2013521タナカ2」　　　「2013521タナカ10」　
「2013521タナカ2」● 「2013521タナカ5」
「2013521サカイ2」　　　「2013521タナカ1」●
「2013521カトウ5」　　　「2013521タナカ2」●

*総合計セル「列」の２割数をだし、Ａ表・Ｂ表の該当する文字の中からその２割相当数の文字に色を付ける。その過程を例に書かせて頂きました。

●で表示したところ文字の「行」に色をつけたいと思っています。
ただし、一つ実際やっていて思ったのですが、Ａ表には同じ文字が２つ存在していたりします。

今回のケースだと、「2013521タナカ2」が該当致します。
しかし、Ｂ表には1つしかないので、Ａ表に色付けする際もできたら、１つにだけ色を付くようにできたら有り難いのですが・・・

VBA作成して下さって、本当にありがとうございます。
しかし、使い方がイマイチよく分からないのですが・・・
1)ALT+F11　で画面をだし、
2)VBA projectの画面に貼り付け
3)Xでエクセルの画面に戻る

「action」はどのように実行したらいいのでしょうか？
（Workbooksでブック名、Sheetsでシート名、Rangeで表のセル範囲をそれぞれ指定）
---＞これはどこにありますか？？？

またお手隙の時にでも教えていただけたら助かります。

回答No.3

nishi6

２つの回答を整理すると、

同じシートで回答します。適宜変更してください。

A表をセルA3:A3002
B表をセルE3:E8002

F3: =countif($A$3:$A$3002,E3)
　　　　　　　F8002までコピー・・・・（１）

G3: =If(F3=1,RAND(),2)
　として下にコピーしこの算式を値複写して値に変えます。
　　　　　　　　・・・・・（２）

H3: =If(G3<=Small($G$3:$G$8002,600),1,0)
　として下にコピーします。
　　　　　　　　・・・・・（３）

A表の条件付き書式の条件は、
　=VLOOKUP(A3,$E$3:$H$8002,4,0) = 1
　　　　　　　　・・・・・（４）

B表の条件付き書式の条件は、
=H3=1

になります。600個固定になるはずです。

まとめると以上のようになります。

（１）でB表のデータがA表にあれば「1」になります。
　　　同じデータは１件としています。

（２）でA表にあった「1」になったデータに1未満の乱数を割り当てています。
　　　A表になかったデータには「2」を割り当てています。小さい方から600個とりたいので、「0」を逆に大きくしています。
　　　乱数を使っているので、ここで算式ではなく、値にしてください。（コピーして同じ箇所に値貼り付けです）

（３）では、値にした乱数の小さい方の600個を1にしています。それ以外は0です。

（４）A表で色を塗るのは、B表の同じ値で、H列が「1」のデータになります。

（５）B表で色を塗るのは、同じ行のH列が「1」のデータになります。

質問から考えた手順は以上のようになります。

お礼

早々にご回答いただき、本当にありがとうございました。
どうしても今日中に提出が必要だった為に、マニュアルで行いました。

しかしながら、また来月には同じ作業があるので、明日再度教えて下さったやり方で出来るかやってみたいと思います。もし、その作業途中で分からない事があれば、再度質問させていただけたら嬉しいです。その際は、お手隙の時にでもまた教えて下さい。お願いいたします。

回答No.2

nishi6

すいません。修正です。600個ジャストにしてみました。

G3: =If(F3=1,RAND(),2)
　として下にコピーしこの算式を値複写して値に変えます。

H3: =If(G3<=Small($G$3:$G$8002,600),1,0)
　として下にコピーします。

A表の条件付き書式の条件は、
　=VLOOKUP(A3,$E$3:$H$8002,4,0) = 1

B表の条件付き書式の条件は、
=H3=1

になります。600個固定になるはずです。

補足

nishi6さん、有難うございます！！

エクセルが不得意であまりよく分かっていないのですが、最初に書いて下さった数式は、Ｆ3とＦ2は利用して、Ｇ3からこの回答して下さった式を利用すればいいのでしょうか？

回答No.1

nishi6

同じシートで回答します。適宜変更してください。

A表をセルA3:A3002
B表をセルE3:E8002

F3: =countif($A$3:$A$3002,E3)
　　　　　　　F8002までコピー
F2: =sum(F3:F8002)

G3: =AND(F3=1,(RAND()<=600/$F$2))*1
　　　　　　　G8002までコピー

A表の条件付き書式の条件(カレントセル A3)
　=VLOOKUP(A3,$E$3:$G$8002,3,0)=1

B表の条件付き書式の条件(カレントセル G3)
=G3=1

このくらいでしょうか。満足のいく状態になったら乱数部分をコピーして値にしてください。

乱数を使っているので、600個ピッタリにはならないでしょう。必ず600にするには、何回も試行して600になるのを待つか、600に近い数値になったら値複写して手作業で調整するのでしょうか。

完璧に600にするには、VBAでコードを書いて、600以下を塗って、また残りを塗ってを繰り返せばいいんですが「そこまでやる？」という感じです。

ご参考に。