[[20061024211146]]　『重複を検索表示』（ＳＬ５６７）　ページの最後に飛ぶ

『重複を検索表示』（ＳＬ５６７）

１つのフォルダーの中にBooK1:BooK2:BooK3:BooK4:BooK5の５個のシートがあります。

BooK1～BooK４までのＯ列に入力した数字＆文字をBooK５のＡ列に表示させてBooK５のＡ列で重複があれば色を付けてあらわしたいのですが？また、BooK５のＢ列に重複ありと表示できれば最高です。

現在はBooK1～BooK4でＯ列で入力したものをBooK5のＡ列に貼り付けて=COUNTIF(Ａ:Ａ,Ａ1000)>1の条件書式で行っています。時間が掛かるしコピーを忘れたりして大変です。。

（BooK1:BooK2:BooK3:BooK4のＯ列には空白箇所もあります）

無理でしょうか？

 それぞれのBookのSheet名はなんでしょうか？
 (ROUGE)

ありがとうございます。Sheet名はBooK1～BooK5まで完了調書と不能調書と言う名前を（２シート）使用しています。よろしくお願い致します。

（ＳＬ５６７）

 スマートなコードではありませんが、このような感じでどうでしょうか？
 (ROUGE)
'----
Sub test()
    Dim tbl1, tbl2, dic1 As Object, dic2 As Object
    Dim wb As Workbook, x, i As Long
    Dim flg1 As Boolean, flg2 As Boolean, flg3 As Boolean, flg4 As Boolean
    flg1 = True: flg2 = True: flg3 = True: flg4 = True
    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    For Each wb In Workbooks
        If wb.Name = "Book1.xls" Then flg1 = False
        If wb.Name = "Book2.xls" Then flg2 = False
        If wb.Name = "Book3.xls" Then flg3 = False
        If wb.Name = "Book4.xls" Then flg4 = False
    Next
    If flg1 Then Workbooks.Open ThisWorkbook.Path & "\Book1.xls"
    If flg2 Then Workbooks.Open ThisWorkbook.Path & "\Book2.xls"
    If flg3 Then Workbooks.Open ThisWorkbook.Path & "\Book3.xls"
    If flg4 Then Workbooks.Open ThisWorkbook.Path & "\Book4.xls"
    For Each x In Array("Book1.xls", "Book2.xls", "Book3.xls", "Book4.xls")
        With Workbooks(x)
            With .Sheets("完了調書")
'                tbl1 = .Range("O1:O" & .Range("O" & Rows.Count).End(xlUp).Row)
                tbl1 = .Range("O:O")
            End With
            With .Sheets("不能調書")
'                tbl2 = .Range("O1:O" & .Range("O" & Rows.Count).End(xlUp).Row)
                tbl2 = .Range("O:O")
            End With
        End With
        For i = 1 To UBound(tbl1, 1)
            If Not IsEmpty(tbl1(i, 1)) Then
                If Not dic1.Exists(tbl1(i, 1)) Then
                    dic1(tbl1(i, 1)) = False
                Else
                    dic1(tbl1(i, 1)) = True
                End If
            End If
        Next
        For i = 1 To UBound(tbl2, 1)
            If Not IsEmpty(tbl2(i, 1)) Then
                If Not dic2.Exists(tbl2(i, 1)) Then
                    dic2(tbl2(i, 1)) = False
                Else
                    dic2(tbl2(i, 1)) = True
                End If
            End If
        Next
    Next
    If flg1 Then Workbooks("Book1.xls").Close
    If flg2 Then Workbooks("Book2.xls").Close
    If flg3 Then Workbooks("Book3.xls").Close
    If flg4 Then Workbooks("Book4.xls").Close
    i = 0
    With ThisWorkbook
        With .Sheets("完了調書").Range("A:B")
            .ClearContents
            .Interior.ColorIndex = xlNone
        End With
        With .Sheets("不能調書").Range("A:B")
            .ClearContents
            .Interior.ColorIndex = xlNone
        End With
        For Each x In dic1.Keys
            i = i + 1
            With .Sheets("完了調書").Range("A" & i)
                .Value = x
                If dic1(x) Then
                    .Interior.ColorIndex = 6
                    .Offset(, 1).Value = "重複"
                End If
            End With
        Next
        i = 0
        For Each x In dic2.Keys
            i = i + 1
            With .Sheets("不能調書").Range("A" & i)
                .Value = x
                If dic2(x) Then
                    .Interior.ColorIndex = 6
                    .Offset(, 1).Value = "重複"
                End If
            End With
        Next
    End With
    Erase tbl1, tbl2
    Set dic1 = Nothing
    Set dic2 = Nothing
End Sub

ありがとうございました。しかしBooK5にマクロを入れてみましたがＡ列にBooK1～BooK4の数字がでません？？エラー１３と出てしまいます？BooK1～BooK4にもマクロをいれるのでしょうか？

 Book5に入れたのであればOKだと思いますが・・・
 A列ではなくO列に書き出ししています。
 エラーはコードのどの部分で出たのでしょうか？
 (ROUGE)
 #A列って書いてありましたね・・・orz　修正済み

ありがとうございました。しかしエラーが？？

Microsoft Visuai Basic

実行時エラー１３

型が一致しません

上記のメッセージが出てしまいます。。。デバッグをクリックするとマクロ式の中の

For i = 1 To UBound(tbl1, 1)の部分が黄色くなります？？

（ＳＬ５６７）

 Book1～5のいずれかのシートで、O列に何も記入されていない場合があるものと思われます。
 コード修正しておりますので、お試し下さい。
 (ROUGE)

何度もすみません。入れ直しましたが今度は実行時エラー9インデックスが有効範囲にありません！表示が出てしまいます？？

With Sheets("完了調書").Range("A:B")が黄色く？？（ＳＬ５６７）

 Book5のSheet名は完了調書と不能調書ではないのでしょうか？
 (ROUGE)

Book5のSheet名は完了調書と不能調書ですが？？（ＳＬ５６７）

 ピリオドふたつつけわすれてました＾＾；(ROUGE)

ありがとうございました。感激です！！出来ました。。

今後も、上記のマクロを利用させて頂きます。。質問です。

BooK1:BooK2:BooK3:BooK4:BooK5の名前が違う場合はマクロの中のBooK1～BooK4で記入されている部分を変更すれば可能でしょうか？同様にシート名も？

 こちらであれば、名前の変更は不要になります。
 ちなみに、Book5のあるフォルダにあるファイルはすべて対象となってしまいますので、
 対象となるファイルだけを入れるようにしてください。
 Sheet名は一箇所だけ変更すれば良いようにしています。
 (ROUGE)
'----
Sub Sample()
    Dim fso As Object, dic1 As Object, dic2 As Object, wb As Workbook
    Dim myFile, tbl1, tbl2, x, flg As Boolean, i As Long
    Const sh1 As String = "完了調書"
    Const sh2 As String = "不能調書"
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    For Each myFile In fso.GetFolder(ThisWorkbook.Path).Files
        If Right(myFile.Name, 4) <> ".xls" Then GoTo AAA
        If myFile.Name = ThisWorkbook.Name Then GoTo AAA
        flg = True
        For Each wb In Workbooks
            If myFile.Name = wb.Name Then
                flg = False
                Exit For
            End If
        Next
        If flg Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & myFile.Name)
        tbl1 = wb.Sheets(sh1).Range("O:O")
        tbl2 = wb.Sheets(sh2).Range("O:O")
        For i = 1 To UBound(tbl1, 1)
            If Not IsEmpty(tbl1(i, 1)) Then
                If Not dic1.Exists(tbl1(i, 1)) Then
                    dic1(tbl1(i, 1)) = False
                Else
                    dic1(tbl1(i, 1)) = True
                End If
            End If
        Next
        For i = 1 To UBound(tbl2, 1)
            If Not IsEmpty(tbl2(i, 1)) Then
                If Not dic2.Exists(tbl2(i, 1)) Then
                    dic2(tbl2(i, 1)) = False
                Else
                    dic2(tbl2(i, 1)) = True
                End If
            End If
        Next
        Erase tbl1, tbl2
        If flg Then wb.Close
AAA:
    Next
    With ThisWorkbook
        With .Sheets(sh1).Range("A:B")
            .ClearContents
            .Interior.ColorIndex = xlNone
        End With
        With .Sheets(sh2).Range("A:B")
            .ClearContents
            .Interior.ColorIndex = xlNone
        End With
        i = 0
        For Each x In dic1.Keys
            i = i + 1
            With .Sheets(sh1).Range("A" & i)
                .Value = x
                If dic1(x) Then
                    .Interior.ColorIndex = 6
                    .Offset(, 1).Value = "重複"
                End If
            End With
        Next
        i = 0
        For Each x In dic2.Keys
            i = i + 1
            With .Sheets(sh2).Range("A" & i)
                .Value = x
                If dic2(x) Then
                    .Interior.ColorIndex = 6
                    .Offset(, 1).Value = "重複"
                End If
            End With
        Next
    End With
    Set dic1 = Nothing
    Set dic2 = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
End Sub

コメント返信：

[ 一覧(最新更新順) ]

[[20061024211146]] 『重複を検索表示』（ＳＬ５６７） ページの最後に飛ぶ

[[20061024211146]]　『重複を検索表示』（ＳＬ５６７）　ページの最後に飛ぶ