Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2007)
他のブックの値の参照
投稿日時: 18/01/24 21:43:36
投稿者: FILETUBE

こんばんは。
 
項目名 番号1 番号2 番号3 フラグ
A 1 5 8
B 3 7 9
C 5 8 9
    
の内容のブック名Aと
 
番号
7
10
12
 
の内容のブックBがあります。
 
ブックAの全行、全番号をチェックしたいのですが、
チェックの内容は番号がブックBに存在していたら
フラグ欄にnoをセットします。
 
For next でブックAをloop
  For next でブックAの番号列をloop
      For next でブックBをloopし
             If ブックAのcell = ブックBのcell then
                エラー
のようなチェック方法を考えているのですが
皆さんは、どのようなチェックをされますか?
 
コードを省略してすいません。
 
Findとかを使うのでしょうか?
 
分かるかたおられましたら、よろしくお願いします。

回答
投稿日時: 18/01/24 22:09:24
投稿者: 隠居じーさん

こんばんは ^^
 
BOOK A の 何と言う名前のシートの 何という列の何行目から何列の何行目
に ご呈示の情報は格納されているのでしょうか。
BOOK B についても
BOOK A と同じく 番号がいずこにあるかご呈示いただき、
同時に作成中のコードを提示され、
お困りの部分を具体的におたずねになれば、回答が得られ安いのではないでしょうか。

回答
投稿日時: 18/01/25 04:46:46
投稿者: もこな2

ちょっとわからないので確認です。

FILETUBE さんの引用:
ブックAの全行、全番号をチェックしたい
とのことですけど、フラグ欄が1列しかないってことは、たとえば、項目名「A]だったら、1と5と8があったら「no」って出したいのか、いずれかがあったら「no」ってしたいのかどちらでしょう?
 
また、ブックBは、重複番号はないんでしょうか?
(あるかないか見るだけなら重複してても関係ないかもですけど。。)
 
 
FILETUBE さんの引用:
Findとかを使うのでしょうか?
こちらはどういう意味でしょうか・・・Findメソッド使う以外の方法があればついでに聞いておきたいってことでしょうか?
Findメソッド使わない方法だとすれば、Dictionaryオブジェクト使って、ブックBの情報で連装配列作っておいて、連装配列のキーに「番号」が含まれているかいないか判定するとかであればいけそうな気がします。

回答
投稿日時: 18/01/25 09:44:26
投稿者: mattuwan44

Sub test001()
    Dim r As Range
    Dim c As Range
    Dim flg As Range
     
    For Each r In Range("B2:D4").Rows
        For Each c In r.Cells
            If WorksheetFunction.CountIf(Range("G2:G5"), c.Value) Then Exit For
        Next
        If Not c Is Nothing Then r.Cells(1, r.Cells.Count + 1).Value = "no"
    Next
End Sub
 
参考まで。速いか遅いかは知りません。ご自分で試して研究してください。

回答
投稿日時: 18/01/25 10:06:52
投稿者: WinArrow
投稿者のウェブサイトに移動

ブックA側
 1行に3つの数値がありますが、
フラグは、3つの内1つでも一致していれば、「no」
 3つが全部一致していれば「no」なのか?
 
要するに、どの数値が一致していたかが分からなくてよいのか?
という質問です。

回答
投稿日時: 18/01/25 12:19:21
投稿者: もこな2

WinArrowさんの 18/01/25 10:06:52のコメントを拝見して、いずれかが含まれている、全部が含まれているのほかに、どこに含まれているかを出力したいってパターンもあり得るなあとおもいました。
ここが解らないと、アドバイス難しいです。
 
とりあえずFindメソッド使わない例として、Dictionaryオブジェクト使った例を提示します。
(ブックを2つ用意するのがめんどくさかったのでシートで説明してます。)

Sub Sample()
'==変数の宣言とか
    Dim i As Long
    Dim objDIC As Object
        Set objDIC = CreateObject("Scripting.Dictionary")
    Dim FLAG_1 As Boolean, FLAG_2 As Boolean, FLAG_3 As Boolean

'==処理1(連想配列を作る)
    With ThisWorkbook.Worksheets("ブックB")
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            objDIC(.Cells(i, "A").Value) = ""
        Next i
    End With

'==処理2(行ごとに「番号1〜3」が連想配列にあるか評価するして、結果出力する)
    With ThisWorkbook.Worksheets("ブックA")
        For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            FLAG_1 = objDIC.Exists(.Cells(i, "B").Value)
            FLAG_2 = objDIC.Exists(.Cells(i, "C").Value)
            FLAG_3 = objDIC.Exists(.Cells(i, "D").Value)
            '↑評価対象が多ければFLAGを配列にしてループ回した方がいいかも

            '各フラグを評価して「no」を出力するか判定
            '(全部含まれているときに「no」だったら、orをandに変えてください。)
            If FLAG_1 Or FLAG_2 Or FLAG_3 Then
                .Cells(i, "E").Value = "no"
            End If
        Next i
    End With

End Sub

回答
投稿日時: 18/01/25 14:20:46
投稿者: WinArrow
投稿者のウェブサイトに移動

VBAで無くても、一般機能の数式で対応可能です。
 
ブックA側
番号1、番号2、番号3に対応する
フラグ1、フラグ2、フラグ3の列を用意します。
仮に、E列、F列、G列とします。
 
セルE2に
=IF(COUNTIF([BookB.xls]Sheet1!$A:$A,B2)>0,"no","")
を入力し、右へフィルドラッグ
E2〜G2を選択し、下へフィルドラッグします。
 
BookB側は、Sheet1のA列に数値が入力されているものと仮定してあります。
 
VBAでのループ処理より、圧倒的に早いです。
 
他の回答者からもコメントあるように
ブックの名前、シートの名前、データが格納されているセル範囲を
キチンと説明するようにお願いします。
回答者とのキャッチボールが減ります。

投稿日時: 18/01/25 19:36:41
投稿者: FILETUBE

こんばんは。
まずシートは全て1番目です。
また、チェックはフラグ列は1つしかありませんので
ブックBの何かの値があればnoをセットします。
 
 
このようなコードを書いてみました。
 wbはブックBを読み取り専用でセットします。
Dim wb as workbook
Set wb = workbooks(B.xlsx)
 
 
Dim r as range
Dim r2 as range
 
For each r in thisworkbook.sheets(1).ranges(B1:D3)
       Set r2 = wb.sheets(1).cells.find(what:= r.value,LookAt:=xlwhole)
       If r2 is nothing then
           This was.cells(r.cells.row,5) = “no”
       End if
       Set r2 = nothing
Next
 
他にもっと効率の良い書き方がないかと思い
投稿しました。
 
どうぞよろしくお願いします。

回答
投稿日時: 18/01/25 20:39:01
投稿者: WinArrow
投稿者のウェブサイトに移動

では、フラグを1列とした
数式を紹介します。
 
セルE2に
=IF(OR(COUNTIF([BookB.xls]Sheet1!$A:$A,B2)>0,COUNTIF([BookB.xls]Sheet1!$A:$A,C2)>0,COUNTIF([BookB.xls]Sheet1!$A:$A,D2)>0),"no","")
 
これはループ不要です。
 
ブックAのデータは、3行程度なんですか?
3行くらいならば、コードを作成しているより数式入力方が早いと違いますか?
 
この数式をセルに代入するコードを考えてみてください。
 
 
掲示したコードは、考え方のサンプルと考えてよいのでしたら、このままでもよいが
実際のコードとしては使えませんよ。!
 
>For each r in thisworkbook.sheets(1).ranges(B1:D3)
> This was.cells(r.cells.row,5) = “no”
↑赤字部分は、コンパイルエラー
 
 
> This was.cells(r.cells.row,5) = “no”
を Thisworkbook.Sheets(1).cells(r.cells(r.cells.row,5)
と仮定すると
Thisworkbook.Sheets(1).Cells(r.Row, 5)
でよい。
 
※コードは、コードペインからコピペしましょう。
手入力で間違えたコードで回答者から突っ込まれないようにしましょう。

投稿日時: 18/01/25 20:59:15
投稿者: FILETUBE

回答ありがとうございます。
 
すいません、テスト的にデータを少なく、列も少なくしています。
本来なら、ブックAは2000行、チェックする番号列は20列、ブックBは1000行になります。
 
最初はfor next で全行、全列、ブックBとloopして比較していました。
For 行
   For 番号列
       For ブックB
            If ブックAの番号 = ブックBの番号 then
                  ブックAのフラグ= No
                   Exit for
            End if
       Next
   Next
Next
 
のような感じになります。
 
少し時間がかかるので他の方法を模索していました。
  
ブックA、Bのデータも増えたりしますので、
できればVBAでと思います。
 
下手な説明ですいません。
どうぞよろしくお願いします。

回答
投稿日時: 18/01/25 21:28:00
投稿者: WinArrow
投稿者のウェブサイトに移動

>できればVBAでと思います。
 
私の提示した数式をVBAでE列セルに埋め込みすれば、
3行くらいで済みますよ!
 
行数 = Range("A" & Rows.Count).End(xlUP).Row - 1
Range("E2").Resize(行数).Formula - 数式

投稿日時: 18/01/25 22:19:18
投稿者: FILETUBE

WinArrowさん、何度もありがとうございます。
式のセットのやり方は、やった事がなかったです。
明日早速やってみます。
 

回答
投稿日時: 18/01/25 22:54:36
投稿者: WinArrow
投稿者のウェブサイトに移動

>チェックする番号列は20列
さすがに20列は、数式では大変かなと思います。
 
ループを使うとすれば、ブックA側データを配列変数に入れてから
の方が早いと思います。
 
サンプル
Sub test()
Dim BOOKADATA, FLAG
 
Dim R As Long, C As Long
 
    With Workbooks("BOOKA")
        With .Sheets(1)
            With .Range("B2").Resize(.Range("B" & .Rows.Count).End(xlUp).Row - 1, .Cells(2, .Columns.Count).End(xlToLeft).Column - 1)
                BOOKADATA = .Value
            End With
            ReDim FLAG(1 To UBound(BOOKADATA), 1 To 1) As String
        End With
        For R = LBound(BOOKADATA) To UBound(BOOKADATA)
            For C = LBound(BOOKADATA, 2) To UBound(BOOKADATA, 2)
                If WorksheetFunction.CountIf(Workbooks("BOOKB.xlsx").Sheets(1).Columns("A:A"), BOOKADATA(R, C)) > 0 Then
                    FLAG(R, 1) = "no"
                    Exit For
                End If
            Next
        Next
        With Sheets(1)
            .Cells(2, UBound(BOOKADATA, 2) + 2).Resize(UBound(FLAG)).Value = FLAG
        End With
    End With
    MsgBox "END"
 
End Sub
 
20列あれば、その右隣の列に「no」が入ります。
 
 

回答
投稿日時: 18/01/26 15:10:40
投稿者: WinArrow
投稿者のウェブサイトに移動

DCUNT関数を使った別案です。
For〜Loopの階層が1つ減っていることと、
 AA列を作業列として使用しています。
  
Dim R As Long, C As Long
Set BOOKB = Workbooks("BOOKB.xlsx")
Set BOOKA = Workbooks("BOOKA.xlsx")
 With BOOKA
     With .Sheets(1)
         For R = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
             .Range("AA1").Value = "番号"
             C = .Cells(R, "Z").End(xlToLeft).Column
             .Cells(R, "B").Resize(, C).Copy
             .Cells(2, "AA").PasteSpecial _
                 Paste:=xlPasteValues, _
                 Operation:=xlNone, _
                 SkipBlanks:=False, _
                 Transpose:=True
             Application.CutCopyMode = False
             .Cells(R, C + 1).Value = IIf(WorksheetFunction.DCount( _
                     BOOKB.Sheets(1).Columns("A"), _
                     BOOKB.Sheets(1).Range("A1"), _
                     .Range("AA1").Resize(C)) > 0, "no", "")
             .Range("AA1").CurrentRegion.ClearContents
         Next
          Application.Goto .Range("A1"), True
     End With
 End With

回答
投稿日時: 18/01/26 21:22:08
投稿者: WinArrow
投稿者のウェブサイトに移動

追加コメント
  
今回、DCOUNTを初めて使ってみましたが、
このような勉強する機会を与えていただき、ありがとうございます。
  
DCOUNTの条件のセル範囲を縦方向にする必要があり、
 横方向(B列〜20セル)の条件を行列入替で、作業領域に複写し、それを条件範囲としました。
これにより、二重ループを一重ループにすることができ
処理速度が向上したと勝手に考えています。
 
二重ループサンプルとDCOUNTサンプルと処理時間の比較をしたならば、
掲示いただくとありがたいです。
 
 

回答
投稿日時: 18/01/27 08:50:24
投稿者: simple

(1)
質問の最初にある
For next でブックAをloop
   For next でブックAの番号列をloop
       For next でブックBをloopし
             If ブックAのcell = ブックBのcell then
                 エラー

のような疑似コードや、
18/01/25 19:36:41 で、エラーだらけのコードを提示されていますが、
そう言う投稿には賛成しかねます。
 
手抜き過ぎませんか?
>他にもっと効率の良い書き方がないかと思い
というまえにきちんとしたコードを書く練習をしてください。
 
(2)
そもそもですが、
>本来なら、ブックAは2000行、チェックする番号列は20列、ブックBは1000行になります。
ということなら、
フラッグだけ表示されても、20列のうち、どのセルがマッチしたためなのか、
あなたは簡単に判断できるのでしょうか。
マッチしたセルに色をつけるといったアクションが必要にはならないのですか?
 
(3)
私なら例えば、こんなコードにしますね。
(簡単のため、同一のブック内のシートの例にしています。)
 

Sub test()
    Dim dic As Object
    Dim k As Long
    Dim r As Range

    Application.ScreenUpdating = False

    Set dic = CreateObject("Scripting.Dictionary")
    For k = 1 To 1000
        dic(Sheet2.Cells(k, 1).Value) = Empty
    Next

    For Each r In Sheet1.[A1].CurrentRegion
        If dic.exists(r.Value) Then
            r.Interior.Color = 65535 '背景色を黄色に
        End If
    Next
    Application.ScreenUpdating = True
End Sub
>ブックAは2000行、チェックする番号列は20列、ブックBは1000行
でも1秒以内のはずです。
 

投稿日時: 18/01/28 11:14:20
投稿者: FILETUBE

simpleさん、WinArrowさん
回答ありがとうございます。
 
質問の時、EXCELが手元になく手入力して間違ったコードで申し訳ありませんでした。
改めてコードはコピーします。
 
simpleさんのいわれますように、確かにマッチしたセルに色を付けた方が分かりやすいと思います。
また最終的にはマッチした番号を項目名と合わせた2列のデータとして新規ブックに保存したいと思っています。
 
まずはチェックの方法を模索していたのですが
最初の方法
       Dim thisws As Worksheet
       Set thisws = ThisWorkbook.Worksheets(1)
       '***********************
       Dim wb As Workbook
       Set wb = Workbooks.Open("C:\test\B.xlsx", True)
 
       Dim wks As Worksheet
       Set wks = wb.Worksheets(1)
 
       Dim y As Long
       Dim x As Long
       Dim s As Long
       Dim vLst As Long
       Dim vBLst As Long
       '*** データ件数
       vLst = thisws.Range("A1").SpecialCells(xlLastCell).Row
       vBLst = wks.Range("A1").SpecialCells(xlLastCell).Row
       '******************* 
       For y = 3 To vLst
            For x = 2 To 4
                If Trim(thisws.Cells(y, x)) <> "" Then
                    For s = 2 To vBLst
                        If Trim(thisws.Cells(y, x)) = Trim(wks.Cells(s, 1)) Then
                           thisws.Cells(y, 5) = "No"
                        End If
                    Next
                End If
            Next x
       Next y
 
と3重のループでチェックしていました。これでは時間がかかるので
         
別の方法
        Dim thisws As Worksheet
        Set thisws = ThisWorkbook.Worksheets(1)
 
        Dim wb As Workbook
        Set wb = Workbooks.Open("C:\test\B.xlsx", True)
 
        Dim r As Range
        Dim rmst As Range
        Dim vLst As Long
        vLst = thisws.Range("A1").SpecialCells(xlLastCell).Row
        For Each r In ThisWorkbook.Sheets(1).Range("B3:D" & vLst)
           Set rmst = wb.Sheets(1).Cells.Find(what:=r.Value, LookAt:=xlWhole)
           If Not rmst Is Nothing Then
              thisws.Cells(r.Cells.Row, 5) = "NO"
           End If
           Set rmst = Nothing
        Next
        
とFindを使ってみました。
 
チェックの検証の為行数、列数は少なくしてあります。
初歩的な質問で申し訳ありません、再度お聞きしたいのですが
WinArrowさんの教えて頂いたコードの
 
Dim BOOKADATA, FLAG
  
Dim R As Long, C As Long
  
    With Workbooks("A")
        With .Sheets(1)
 
 
 With Workbooks("A")の部分でインデックスが有効範囲にありませんになります。
 
 
またその後の
Dim BOOKB As Workbooks
Dim BOOKA As Workbooks
'
'
Dim R As Long, C As Long
Set BOOKB = Workbooks("C:\test\B.xlsx")
Set BOOKA = Workbooks("C:\test\A.xlsx")
 With BOOKA
     With .Sheets(1)
         For R = 2 To .Range("B" & .Rows.Count).End(xlUp).Row
             .Range("AA1").Value = "番号"
 
のWith .Sheets(1)でコンパイルエラーになってしまいます。
 
大変申し訳ありません、どうぞ宜しくお願いします。

回答
投稿日時: 18/01/28 12:21:23
投稿者: もこな2

FILETUBE さんの引用:
With Workbooks("A")の部分でインデックスが有効範囲にありませんになります。
私の環境(エクセル2007)でテストしてみましたが、同じエラーになり、(A.xlsx)と拡張子までいれたらいけたので、参考にして下さい。
 
FILETUBE さんの引用:
またその後の
のWith .Sheets(1)でコンパイルエラーになってしまいます。
こちらは、私の環境ではテストは成功したので、原因不明です。(上記のエラーがでたまま、無理矢理進めたとかではないですよね?コンパイルエラーって言ってるから違うでしょうけど・・・)
 
FILETUBE さんの引用:
また最終的にはマッチした番号を項目名と合わせた2列のデータとして新規ブックに保存したいと思っています。
やりたいことや困ってることを小出しにせず、最初にちゃんと説明したほうがよろしいような。。。
とりあえず、最終的に欲しいブックのレイアウトというかイメージはどんな感じなのでしょうか
 
番号 項目名
 7 A
        B
        C
1,2 D
 
こんな感じですか?
 
以上、気になったところまで。

回答
投稿日時: 18/01/28 12:41:07
投稿者: simple

あらためてのコード提示、ご苦労様でした。
 
で、ご質問ですが、
    Dim BOOKB As Workbooks
    Dim BOOKA As Workbooks
    Set BOOKB = Workbooks("C:\test\B.xlsx")
    Set BOOKA = Workbooks("C:\test\A.xlsx")
赤にした部分が不適切ですね。
 
# ちなみに、ご自宅のPCにはExcelがインストールされて無いのですか?
# 勉学にも業務にも支障ないのですか?

回答
投稿日時: 18/01/28 12:46:04
投稿者: simple

それともWorkbooks.OpenのOpenが抜けてしまったのかも。

回答
投稿日時: 18/01/28 13:39:51
投稿者: WinArrow
投稿者のウェブサイトに移動

 > With Workbooks("A")
 > With .Sheets(1)
> With Workbooks("A")の部分でインデックスが有効範囲にありませんになります。
  
 そりゃそうでしょう。「A」とうファイル(ブック)は存在しないからです。
タブン
>With Workbooks("A")

With ThisWorkbook
とすればよいとおもいます、
 
  
>のWith .Sheets(1)でコンパイルエラーになってしまいます。
 
エラーの原因は、
>Dim BOOKB As Workbooks
>Dim BOOKA As Workbooks
が適切ではないからです。
 
たぶん
>Dim BOOKB As Workbooks
>Dim BOOKA As Workbooks
 '
 '
 >Dim R As Long, C As Long
 >Set BOOKB = Workbooks("C:\test\B.xlsx")
 >Set BOOKA = Workbooks("C:\test\A.xlsx")

Dim BOOKB As Workbook
Dim BOOKA As Workbook
 '
 '
 Dim R As Long, C As Long
 Set BOOKB = Workbooks.Open("C:\test\B.xlsx")
 Set BOOKA = ThisWorkbook
に修正すればよいと思います。
 
※BOOKAは、マクロ付ブックですから A.xlsmではないですか?
 
 

回答
投稿日時: 18/01/28 15:23:40
投稿者: WinArrow
投稿者のウェブサイトに移動

私は、2つの提案をしています。
前者は、2階建てのループ構造になっていて、
内側のループの中で
1つでも"no"になる条件があると、内側のループを抜ける仕様になっています。
(フラグは1ヶ所でよいという質問者さん意見で)
 
該当するセルに色を設定するとなると、
単純に内側ループを全部回すだけでは、対応できません。
配列変数ではなく、セルを参照する方式に変更する必要があります。
 
後者は、DCOUNT関数を利用しているので、個々のセル認識はできないため、
セルに色を設定することはできません。

回答
投稿日時: 18/01/28 17:29:25
投稿者: もこな2

参考になったのか、なってないのか反応がないからわからないですが、Dictionaryオブジェクトを使って、マッチした番号を項目名と合わせた2列のデータとして新規ブックに出力する一例を提示します。(保存は保存先、ファイル名がわからなかったので省略してます。)
 

Sub Sample改()
'==変数の宣言とか
   Dim i As Long
   Dim objDIC As Object
      Set objDIC = CreateObject("Scripting.Dictionary")
   Dim last_r As Long
   Dim buf As String
   Dim tmp() As String
   Dim MyRNG As Range
   Dim New_WB As Workbook

'==処理1(連想配列を作る)
   With ThisWorkbook.Worksheets("ブックB")
      For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
         objDIC(.Cells(i, "A").Value) = ""
      Next i
   End With

'==処理2(2次元配列にチェック結果を格納する)
   With ThisWorkbook.Worksheets("ブックA")
      last_r = .Cells(.Rows.Count, "A").End(xlUp).Row
      ReDim tmp(1 To last_r - 1, 1 To 2) '2次元配列として再定義
      For i = 2 To last_r
         buf = "" '変数「buf」を初期化
         
         '行ごとにB〜U列の値が「objDIC」に登録されているか調べる
         For Each MyRNG In .Cells(i, "B").Resize(, 20)
            '「MyRNG」の値が「objDIC」に登録されていたら「buf」に追加
            If objDIC.Exists(MyRNG.Value) Then _
               buf = buf & "," & MyRNG.Value
         Next MyRNG
      
         '最初の「,」が邪魔なので消す
         If buf <> "" Then buf = Mid(buf, 2, Len(buf) - 1)
         
         '2次元配列「tmp」に格納する
         tmp(i - 1, 1) = buf
         tmp(i - 1, 2) = .Cells(i, "A").Value
      Next i
   End With

'==処理3(新しいブックを用意して、チェック結果を出力する)
   Set New_WB = Workbooks.Add
   With New_WB
      .Worksheets(1).Range("A1").Resize(UBound(tmp, 1), 2).Value = tmp
   End With

End Sub

投稿日時: 18/01/29 22:08:13
投稿者: FILETUBE

もこな2さん
Simpleさん
WinArrowさん
 
回答ありがとうございます。
 
もこな2さん、simpleさん
WinArrowさんに教えて頂いた内容で2つ目の方法の
エラーは解消されました。
 
チェックした結果は
項目名と番号の2列のブックで書き出します。
保存先はcドライブで,ブック名はチェック+当日日付とします。
Dictionaryと二次元配列の大変詳しい回答ありがとうございます。
 
早速検証してみたいと思います。
 
 
 
 
 
 

回答
投稿日時: 18/01/30 07:37:19
投稿者: simple

チェックした結果は
項目名と番号の2列のブックで書き出します。
保存先はcドライブで,ブック名はチェック+当日日付とします。

こちらは、処理代行サポートではないので、
ご自分でトライして不明な点を質問して下さい。

回答
投稿日時: 18/01/30 09:25:33
投稿者: mattuwan44

Sub test()
    Dim rngTable As Range
    Dim rngList As Range
    Dim rngFlg As Range
    Dim rngWork As Range
    Dim rngResult As Range
    Dim c As Range
    Dim f As String
    Dim ix As Long
     
    With ThisWorkbook
        Set rngTable = .Sheets(1).Range("A1").CurrentRegion
        Set rngList = .Sheets(2).Range("A1").CurrentRegion
        Set rngFlg = Intersect(rngTable, rngTable.Offset(1, 1)).Offset(, rngTable.Columns.Count)
        Set rngWork = .Sheets(3).Range(rngTable.Address)
        Set rngResult = .Sheets(3).Range(rngFlg.Address).Cells(1)
    End With
    f = "=CountIf(" & rngList.Address(, , , True) & "," & rngTable(2, 2).Address(False, False) & ")"
     
    With rngFlg
        .Formula = f
        .Value = .Value
    End With
     
    rngTable.Copy rngWork
    rngFlg.Copy
    rngWork(2, 2).PasteSpecial Operation:=xlDivide
     
    For Each c In rngWork.SpecialCells(xlCellTypeConstants, xlNumbers)
        rngTable.Range(c.Address).Interior.ColorIndex = 6
        rngResult(ix, 1).Value = rngWork(c.Row, 1).Value
        rngResult(ix, 2).Value = rngWork(1, c.Column).Value
    Next
 
    rngFlg.ClearContents
    With rngWork
        .Resize(, .Columns.Count + 1).EntireColumn.Delete
        .worksheet.copy
    End With
End Sub
 
これで、だいぶ高速化出来たんじゃないかと思うけどどうだろう。。。。(試してません^^;)
(シート上の再計算が終るまでVBAの次の命令って待ってくれるんでしたっけ?)
 
ループの回数が多くなるなら、
2次元配列の変数に値を移してからループしたら、さらに高速化できるかとは思います。
 
それから、、、ディクショナリ使うとやっぱ速いです?

投稿日時: 18/01/30 20:49:14
投稿者: FILETUBE

mattuwan44さん、大変丁寧な回答ありがとうございます。
 
ディクショナリを使用していないみたいですが
ポイントはcountifでしょうか。
 
いろいろな方法があって迷ってしまいます。
しかし、本当に詳しいコード、ありがとうございます。
 

投稿日時: 18/02/01 21:37:02
投稿者: FILETUBE

こんばんは。
今回は多くの方に、ご教授頂きありがとうございました。
 
またよろしくお願いします。