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

質問

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

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

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

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

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

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

回答No.16

eden3616

度々申し訳ありません。

No15の回答にて『(2)Match検索のコードを追加』内のコードに誤りがあります。
正しくは以下のコードを使用してください。

'Match検索
Private Function kensaku(tsht As Worksheet, trng As Range, word As String) As Range
Dim hcol As Long
Dim hrow As Long
On Error GoTo era
hcol = trng.Cells(1).Column
hrow = WorksheetFunction.Match(word, trng, 0)
Set kensaku = tsht.Cells(hrow, hcol)
Exit Function
era:
Set kensaku = Nothing
End Function

回答No.15

eden3616

>私のデータのやつからだと上手くいかないのは、
>色々関数を使って作業をしているからですかね？

原因はそれですね。
数式により組み合わさったセルを検索できるようにする必要があります。
Find検索からMatch関数による検索方法に変更する修正をお願いします。

(1)以下の箇所を変更

Set hit = tar_rng(1).Find(tar_rng(0).Cells(i).Value, LookAt:=xlWhole)
　　　　　　　　　　　　　　　↓
Set hit = kensaku(tar_sht(1), tar_rng(1), tar_rng(0).Cells(i).Text)

(2)Match検索のコードを追加

'3次元配列を1次元基準でシャッフル処理
Private Function Shuffle(list As Variant) As Variant
　～省略～
End Function

の次に以下のコードを追加

'Match検索
Private Function kensaku(tsht As Worksheet, trng As Range, word As String) As Range
Dim hcol As Long
Dim hrow As Long
On Error GoTo era
hcol = trng.Cells(1).Column
hrow = WorksheetFunction.Match(word, tsht.Columns(hcol), 0)
Set kensaku = tsht.Cells(hrow, hcol)
Exit Function
era:
Set kensaku = Nothing
End Function

回答No.14

eden3616

同じく2007て使用しています。
実際のデータを拝見できれば原因がわかるかもしれませんが、
逆にこちらで動作したデータを再現出来ますか？
対象のデータをシンプルなケースに作り替えて動作するか確認出来ますか？

お礼

やってみました。
そしたら、きちんと表示もでて上手く起動いたしました。
私のデータのやつからだと上手くいかないのは、色々関数を使って作業をしているからですかね？
色々消してから、再度作業出来るか確認してみたいと思います。

補足

かしこまりました。
一度、シンプルなシートに貼り付けて、再度やってご報告させていただきます～

回答No.13

eden3616

えーっと、ごめんなさい。

ドツボにはまってきそうなので、
一度0から作り変えました。処理方法も変えて簡潔にしました。

以下のVBAコードを既存のコードと全て入れ替えて使用してみてください。
（コード内の[設定項目]のA表及びB表は前回同様に設定願います）

これまでに、ご提示していただいた情報より
設定をなるべく同じ環境にしてテスト動作しました。

「TA」シート、「TL」シートともに「文字列1」～「文字列10000」のデータを用意し、
RAND関数でオートフィルしたものを基準に1～10000行を並び替えたのち
TAシートを"W2:W3108"、TLシートを"AG2:AG2080"のセル範囲を対象として
テスト動作した結果の画像を添付しています。

この結果よりA表全体数が3107、B表全体数が2079になり、
今回A・B一致した文字列の数が650となり、A表の2割数である621が
着色されている事を確認しています。

■VBAコード

Option Explicit

Sub action()
'型宣言
Dim tar_rng(1) As Object, tar_sht(1) As Worksheet
Dim myData1() As Variant, myData2() As Variant
Dim i As Long, j As Long, cnt As Long
Dim hit As Range, lmax As Integer, lpt As String
'[設定項目]-------------------------------
'A表範囲
Set tar_sht(0) = ActiveWorkbook.Sheets("TA")
Set tar_rng(0) = tar_sht(0).Range("W2:W3108")
'B表範囲
Set tar_sht(1) = ActiveWorkbook.Sheets("TL")
Set tar_rng(1) = tar_sht(1).Range("AG2:AG2080")
'-----------------------------------------
'表の背景色クリア
tar_sht(0).Range(tar_rng(0).Cells(1).Row & ":" & tar_rng(0).Cells(tar_rng(0).Count).Row).Interior.Color = xlColorIndexNone
tar_sht(1).Range(tar_rng(1).Cells(1).Row & ":" & tar_rng(1).Cells(tar_rng(1).Count).Row).Interior.Color = xlColorIndexNone
'AB一致する配列を取得
ReDim myData1(tar_rng(0).Count, 2)
For i = 1 To tar_rng(0).Count
　　Set hit = tar_rng(1).Find(tar_rng(0).Cells(i).Value, LookAt:=xlWhole)
　　If Not hit Is Nothing Then
　　　　myData1(cnt, 0) = tar_rng(0).Cells(i).Value
　　　　myData1(cnt, 1) = tar_rng(0).Cells(i).Row
　　　　myData1(cnt, 2) = hit.Row
　　　　cnt = cnt + 1
　　End If
Next i
'余計に確保した配列を削除
ReDim myData2(cnt - 1, 2)
For i = 0 To cnt - 1
　　For j = 0 To 2
　　　　myData2(i, j) = myData1(i, j)
　　Next j
Next i
'配列シャッフル
myData2 = Shuffle(myData2)
'2割数取得
lmax = Int(tar_rng(0).Count * 0.2)
If cnt < lmax Then lmax = cnt
'着色処理
Application.ScreenUpdating = False
For i = 0 To lmax - 1
　　tar_sht(0).Rows(myData2(i, 1)).Interior.Color = RGB(255, 255, 0)
　　tar_sht(1).Rows(myData2(i, 2)).Interior.Color = RGB(255, 255, 0)
Next i
Application.ScreenUpdating = True
'結果出力
lpt = lpt & "対象のブック：" & ActiveWorkbook.Name & vbCrLf
lpt = lpt & "A表シート：" & tar_sht(0).Name & vbCrLf
lpt = lpt & "セル範囲(文字数)：" & tar_rng(0).Address & " (" & tar_rng(0).Count & ")" & vbCrLf
lpt = lpt & "B表シート：" & tar_sht(1).Name & vbCrLf
lpt = lpt & "セル範囲(文字数)：" & tar_rng(1).Address & " (" & tar_rng(1).Count & ")" & vbCrLf
lpt = lpt & "一致した数：" & cnt & vbCrLf
lpt = lpt & "A表の2割数：" & Int(tar_rng(0).Count * 0.2) & vbCrLf
lpt = lpt & "着色した数：" & lmax
MsgBox lpt, Title:="終了しました"
End Sub

'3次元配列を1次元基準でシャッフル処理
Private Function Shuffle(list As Variant) As Variant
Dim tmp(2) As Variant, rn As Double
Dim i As Long, j As Integer
　　For i = 0 To UBound(list, 1)
　　　　Randomize
　　　　rn = Int(UBound(list, 1) * Rnd)
　　　　For j = 0 To 2
　　　　　　tmp(j) = list(i, j)
　　　　　　list(i, j) = list(rn, j)
　　　　　　list(rn, j) = tmp(j)
　　　　Next j
　　Next i
　　Shuffle = list
End Function

補足

本当に色々ありがとうございます。

早速させてもらったら、今度は以下のところがエラーで黄色になっていました。
ReDim myData2(cnt - 1, 2)

何か私のエクセルが悪いんでしょうか？？？
eden3616さんがやってくれると上手くいくのに・・・
ちなみにエクセルのバージョンは関係ありますか？私が会社使用しているのは、エクセル2007です。

回答No.12

eden3616

>この部分が「名前は適切ではありません」と出てきました。

ユーザー関数が重複している場合に出るエラーです。
Function hit(word As String, tar As Object) As Long
～
End Function
のコードを重複してモジュール内に配置していませんか？
一度すべてのコードを削除して以下のコードを使用してください。

■VBAコード

Option Explicit

Sub action()
Dim tar_a(2) As Object, tar_b(2) As Object
Dim i As Long, hword(2) As Variant, cnt As Long, lmax As Long, lhit As Long
Dim myAry1(), myAry2()
Dim tar As Object, kekka As String
'On Error GoTo era
'-----------------------------------------
'★表Aの範囲設定
' A表のシート名
Set tar_a(0) = ActiveWorkbook.Sheets("TA")
' A表のセル範囲
Set tar_a(1) = tar_a(0).Range("W2:W3108")

'★表Bの範囲設定
' B表のシート名
Set tar_b(0) = ActiveWorkbook.Sheets("TL")
' B表のセル範囲
Set tar_b(1) = tar_b(0).Range("AG2:AG2080")
'-----------------------------------------
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
lhit = WorksheetFunction.Round(tar_a(1).Rows.Count * 0.2, 0)
Debug.Print "x0.2cnt = " & lhit
lmax = tar_a(1).Rows.Count - cnt + lhit
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) = tar_a(1).Find(CStr(myAry1(i, 0)), lookat:=xlWhole).Row
hword(1) = tar_b(1).Find(CStr(myAry1(i, 0)), lookat:=xlWhole).Row
If hword(1) > 0 Then
tar_a(0).Rows(hword(0)).Interior.Color = RGB(255, 255, 0)
tar_b(0).Rows(hword(1)).Interior.Color = RGB(255, 255, 0)
End If
Next i
kekka = _
"A表の全数：" & tar_a(1).Rows.Count & vbCrLf & _
"A,B表に一致した全数：" & lmax & vbCrLf & _
"A表全体の2割数：" & lhit
MsgBox kekka, Title:="処理結果"
Exit Sub
era:
kekka = kekka & "表Aシート："
If tar_a(0) Is Nothing Then kekka = kekka & "Nothing" & vbCrLf Else kekka = kekka & tar_a(0).Name & vbCrLf
kekka = kekka & "表Aセル範囲："
If tar_a(1) Is Nothing Then kekka = kekka & "Nothing" & vbCrLf Else kekka = kekka & tar_a(1).Address & vbCrLf
kekka = kekka & "表Bシート："
If tar_b(0) Is Nothing Then kekka = kekka & "Nothing" & vbCrLf Else kekka = kekka & tar_b(0).Name & vbCrLf
kekka = kekka & "表Bセル範囲："
If tar_b(1) Is Nothing Then kekka = kekka & "Nothing" & vbCrLf Else kekka = kekka & tar_b(1).Address & vbCrLf
MsgBox kekka, Title:="エラーが発生しました"
End Sub

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

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

補足

度々、本当にありがとうございます。
今度は以下のメッセージがでてきました。
「実行時エラー’91’　オブジェクト変数またはWithブロック変数が設定されていません」

hword(0) = tar_a(1).Find(CStr(myAry1(i, 0)), lookat:=xlWhole).Row
この部分に黄色でマークがでていました。

どうでしょうか？？？

回答No.11

eden3616

申し訳ありません。
今まで出ていたエラー「インデックスが有効範囲にありません」とは別のものです。

コード全差替えの時に必要なプロシージャ（コードの1塊）を外していました。
コードの一番最後（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

補足

本当に度々、有難うございます♪
早速、コードを追加させていただきました。そしたら、

Function hit(word As String, tar As Object) As Long
この部分が「名前は適切ではありません」と出てきました。

お手隙の時にでも、もう一度みていただけたら助かります！！

回答No.10

eden3616

お手数おかけします。

>何度やっても以下のメッセージがでる
>ファイル自体は開いたまま作業している
>”「2013年下期(作業)別.xls」を指定してください”

開いても指定ダイアログが表示されるということは
何故かブックを認識できていませんね。
『A表、B表は同じブックであり、別のシートまたは同じシートである』
という事を前提に方針を変えてコードを変更します。

(1)以下のVBAコードと差し換え（全て差し換え）
(2)A・B表の『シート名』と『セル範囲』のみ設定
(3)『対象のブック』を開き
(4)『開いたブックを選択した状態』で『action』を実行

(4)で現在表示（アクティブ）のブックを対象のブックとし、
コード内で指定したシート名、セル範囲を表AとBとして処理を行います。

処理が最後まで終了すると『処理結果』を表示するようにしました。
表A・Bの対象が取得できない場合エラーメッセージ「Nothing」が出ます。

■VBAコード

Option Explicit

Sub action()
Dim tar_a(2) As Object, tar_b(2) As Object
Dim i As Long, hword(2) As Variant, cnt As Long, lmax As Long, lhit As Long
Dim myAry1(), myAry2()
Dim tar As Object, kekka As String
On Error GoTo era
'-----------------------------------------
'★表Aの範囲設定
' A表のシート名
Set tar_a(0) = ActiveWorkbook.Sheets("TA")
' A表のセル範囲
Set tar_a(1) = tar_a(0).Range("A4:A8")

'★表Bの範囲設定
' B表のシート名
Set tar_b(0) = ActiveWorkbook.Sheets("TB")
' B表のセル範囲
Set tar_b(1) = tar_b(0).Range("Ａ13: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
lhit = WorksheetFunction.Round(tar_a(1).Rows.Count * 0.2, 0)
Debug.Print "x0.2cnt = " & lhit
lmax = tar_a(1).Rows.Count - cnt + lhit
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) = tar_a(1).Find(CStr(myAry1(i, 0)), lookat:=xlWhole).Row
hword(1) = tar_b(1).Find(CStr(myAry1(i, 0)), lookat:=xlWhole).Row
If hword(1) > 0 Then
tar_a(0).Rows(hword(0)).Interior.Color = RGB(255, 255, 0)
tar_b(0).Rows(hword(1)).Interior.Color = RGB(255, 255, 0)
End If
Next i
kekka = _
"A,B表に一致した全数：" & lmax & vbCrLf & _
"一致した数の2割数：" & lhit
MsgBox kekka, Title:="処理結果"
Exit Sub
era:
kekka = kekka & "表Aシート："
If tar_a(0) Is Nothing Then kekka = kekka & "Nothing" & vbCrLf Else kekka = kekka & tar_a(0).Name & vbCrLf
kekka = kekka & "表Aセル範囲："
If tar_a(1) Is Nothing Then kekka = kekka & "Nothing" & vbCrLf Else kekka = kekka & tar_a(1).Address & vbCrLf
kekka = kekka & "表Bシート："
If tar_b(0) Is Nothing Then kekka = kekka & "Nothing" & vbCrLf Else kekka = kekka & tar_b(0).Name & vbCrLf
kekka = kekka & "表Bセル範囲："
If tar_b(1) Is Nothing Then kekka = kekka & "Nothing" & vbCrLf Else kekka = kekka & tar_b(1).Address & vbCrLf
MsgBox kekka, Title:="エラーが発生しました"
End Sub

Sub QuickSort(ByRef argAry() As Variant, ByVal lngMin As Long, ByVal lngMax As Long, ByVal keyPos As Long)
Dim i As Long, j As Long, k As Long
Dim vBase As Variant, 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

補足

本当に何度もありがとうございます。
私が全然理解していないので、本当にご迷惑ばかりお掛けします。

http://firestorage.jp/download/ee6b26c8bb1f1324e2f43fc44c37dd6da27b9a2f

エラーがやはり出ちゃいまして、画面コピーして一度見てもらった方がいいのかも思い、貼り付けて
させていただいております。
もしお時間あれば見ていただけたら助かります。

回答No.9

eden3616

度重なる回答で混乱させてしまっているようですので一度整理いたします。

結論を述べさせていただきますと、
No5のコードにNo7の修正（(1)及び(2)）を適応して頂いたものを利用してください。
No8に追記させて頂いてますセルの範囲も忘れずに設定してください。

■No6の回答について
>前々回に書いて下さった以下のやつは、入力していないのですが、これも入れた方がいいのでしょうか？

No5の補足で発生したインデックスの有効範囲外エラーの発生原因として
対象としている表のブックまたはシートが見つからないことが原因と思われます。
見つからなかった原因として、コード内でのブックまたはシート名の設定ミスによる可能性があります。

No6のコードは対象となるブックの名前やシートの名前をイミディエイトウィンドウに表示するもので
意図としては表示された名前をNo5のコード内でコピーペーストして頂ければと作成したものです。
コピーペーストですので入力ミスの対応になればと作成したものです。
本体の動作に関連しておりませんので不要です。

■メッセージについて
>”「2013年下期(作業)別.xls」を指定してください”というメッセージがでてきました。

No6にて上記「設定ミスが原因」という可能性を元に回答させて頂いたのですが、
No7にて「対象のブックが開かれていないのにマクロを実行したことが原因」である可能性があるため
該当箇所の対応コードを記述させていただきました。

これにより、コード内の「■表Aの範囲設定」及び「■表Bの範囲設定」で設定したブックが見つからない（開かれていない）場合、
ダイアログを表示し、AまたはBのブックを開くためのウィンドウを表示するように対応しました。

このダイアログが表示されたということは、「2013年下期(作業)別.xls」が開かれていないまま「action」が実行されています。

ダイアログの指示に従い、「2013年下期(作業)別.xls」のブックを再度指定してください。
再度指定されたブックをプログラムが開いてから処理を行います。
また「2013年下期(作業)別.xls」ブックが開かれた状態で「action」を実行して頂ければ上記ダイアログは表示されません。

補足

何度やっても以下のメッセージがでてきます。。。ファイル自体は開いたまま作業しているのですが・・・
また、画面の指示通り、再度指定して行おうとすると、画面が「読み取り専用」に変わり、再度actionボタンを押そうとすると、また以下のメッセージが出るの繰り返しになります。

原因が分からないのですが、もう少し仕事の合間に調べて、せっかく作って下さったコードを使いたいと思います。

”「2013年下期(作業)別.xls」を指定してください”

急ぎ、ご報告まで

回答No.8

eden3616

記述し忘れておりましたが、回答No.7の「■VBAコードの修正」の(1)において
「' A表のセル範囲」の「"A4:A8"」と「' B表のセル範囲」の「"Ａ13:A17"」は
ご利用のファイルに合わせて修正願います。

「ブック名が異なっている」又は「対象のファイルが開かれていない」場合はNo7の修正により対応されますが、
「指定したシート名が見つからない」場合のエラー対応はコードが長くなるため行っておりません。
必要であれば追加いたしますのでご提示ください。

補足

eden3616さん、本当に何度もありがとうございます。

登録し直し、マクロを起動させてみようと、「action」を押してみたんですが、以下のメッセージがでてきました。
”「2013年下期(作業)別.xls」を指定してください”というメッセージがでてきました。

前々回に書いて下さった以下のやつは、入力していないのですが、これも入れた方がいいのでしょうか？
以下のマクロを実行して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

何度も色々とご迷惑掛けて、本当にすみませんm(__)m

回答No.7

eden3616

■エラーについて

>以下の箇所でエラーの黄色がでていました。
>入力に間違いはないと思う

No5にて以下のように回答させて頂きましたが、不足していた事柄があります。

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

実行時には『A表・B表の記述されているブックを開いている』状態で実行する必要があります。
入力した情報が正しいのであれば、これが原因ではないでしょうか。

>Bのやつは色が付かなかった
>Ａの方だけ何故か色がつきました。

マクロは上から順に処理が行われます。
上に記述したコードで処理場発生したエラーであれば該当箇所で処理が停止してしまうため下に記述したB表のコードは処理されていません。
対象のブックが開かれていない事が原因であればB表のほうでも処理が行われればエラーが出ると思います。
（AとBのコードを逆に入れ替えて実行すればBでもエラーが出るかと思います）

■VBAコードの修正

ブックが開かれていない場合、ファイルを開くダイアログを表示してファイルの指定を促し、ファイルを開いた後に処理を行うようにコードを修正します。コード内の以下の(1)、(2)の箇所を修正してください。

(1)範囲設定を以下のコードと置き換えてください。

'-----------------------------------------
'■表Aの範囲設定
' A表の対象ブック名および対象シート名の設定
Set tar_a(0) = ckbook("2013年下期(作業用)別.xls")
If tar_a(0) Is Nothing Then Exit Sub
Set tar_a(0) = tar_a(0).Sheets("TA")
' A表のセル範囲
Set tar_a(1) = tar_a(0).Range("A4:A8")

'■表Bの範囲設定
' B表の対象ブック名および対象シート名の設定
Set tar_b(0) = ckbook("2013年下期(作業用)別.xls")
If tar_b(0) Is Nothing Then Exit Sub
Set tar_b(0) = tar_b(0).Sheets("TB")
' B表のセル範囲
Set tar_b(1) = tar_b(0).Range("Ａ13:A17")
'-----------------------------------------

(2)以下のコードをコードの一番最後（『Sub QuickSort ～ End Sub』の下）に追加してください。

Function ckbook(book As String) As Object
Dim fpath As String
On Error GoTo era
Set ckbook = Workbooks(book)
Exit Function
era:
fpath = Application.GetOpenFilename( _
FileFilter:="ファイル,*.*", _
Title:=book & "を指定してください")
If fpath = "False" Then
Set ckbook = Nothing
MsgBox "ファイルの指定がキャンセルされました" & vbCrLf & "終了します"
Exit Function
End If
Set ckbook = Workbooks.Open(Filename:=fpath, ReadOnly:=True)
End Function