Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


1895 / 13645 ツリー ←次へ | 前へ→

【71162】異なるデータを抽出させる PePe 12/2/3(金) 10:36 質問[未読]
【71164】Re:異なるデータを抽出させる kanabun 12/2/3(金) 11:03 回答[未読]
【71167】Re:異なるデータを抽出させる PePe 12/2/3(金) 11:29 質問[未読]
【71168】Re:異なるデータを抽出させる Hirofumi 12/2/3(金) 11:31 発言[未読]
【71170】Re:異なるデータを抽出させる Hirofumi 12/2/3(金) 11:57 発言[未読]
【71172】Re:異なるデータを抽出させる Hirofumi 12/2/3(金) 12:42 発言[未読]
【71171】Re:異なるデータを抽出させる kanabun 12/2/3(金) 11:59 発言[未読]
【71166】Re:異なるデータを抽出させる kanabun 12/2/3(金) 11:21 発言[未読]
【71169】Re:異なるデータを抽出させる kanabun 12/2/3(金) 11:32 発言[未読]
【71173】Re:異なるデータを抽出させる PePe 12/2/3(金) 15:47 お礼[未読]
【71175】Re:異なるデータを抽出させる kanabun 12/2/3(金) 17:04 発言[未読]
【71176】Re:異なるデータを抽出させる kanabun 12/2/3(金) 18:29 発言[未読]
【71177】Re:異なるデータを抽出させる kanabun 12/2/3(金) 19:08 発言[未読]

【71162】異なるデータを抽出させる
質問  PePe  - 12/2/3(金) 10:36 -

引用なし
パスワード
   Book1のシート1のA列とBook2のシート1のA列のデータ比較で

同じでないものをBook2から拾ってBook1に取り込みたいのですが・・・
コードを書いたのですが、思った動作をしません、コードのチェックをしていただけませんでしょうか。よろしくお願いします。

Dim i As Integer, k As Integer
 Dim LstR1 As Long, LstR2 As Long, Bk1, Bk2
  Set Bk1 = ThisWorkbook
  Set Bk2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx")
 
   With Bk1.Worksheets("sheet1")
   LstR1 = .Cells(Rows.Count, 1).End(xlUp).Row
   LstR2 = Bk2.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
   For k = 1 To LstR1
   For i = 1 To LstR2
     If .Cells(k, 1) <> Bk2.Sheets("sheet1").Cells(i, 1) Then
      Exit For
     End If
   Next i
   Next k
   If k > LstR2 Then
    Bk2.Sheets("sheet1").Cells(i, 1).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
   End If
   
   End With
   Bk2.Close True
   Bk1.Save

【71164】Re:異なるデータを抽出させる
回答  kanabun  - 12/2/3(金) 11:03 -

引用なし
パスワード
   ▼PePe さん:
>コードを書いたのですが、思った動作をしません、
>   For k = 1 To LstR1
>     For i = 1 To LstR2
>       If .Cells(k, 1) <> Bk2.Sheets("sheet1").Cells(i, 1) Then
>         Exit For
>       End If
>     Next i
   ↑この部分ですけど、For i = 1 To LstR2 で Bk2のシートをループして
    見つからなかったときは i が LstR2 +1 になっているんじゃないですか
    ⇒ ここに BK1への転記が必要になる、と思う
>   Next k
>   If k > LstR2 Then
>      Bk2.Sheets("sheet1").Cells(i, 1).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
>   End If

と思ったけど、Bk1にないBk2のデータを Bk1 に転記したいんですよね?
そしたら、
For k = 1 to LstR2 ' Bk2のLoop
  もし Bk2Sheet の.Cells(k,1) の値が 「Bk1になかったら」
    Bk2Sheet の.Cells(k,1) の値を Bk1シートの最終行に転記
   End If
Next
と方向を逆にする必要があるんじゃないですか?

あと、
あるか/ないか の「検索」は Findメソッドとか もっと効率の良い
方法がありますが。

【71166】Re:異なるデータを抽出させる
発言  kanabun  - 12/2/3(金) 11:21 -

引用なし
パスワード
   Findメソッドでの検索は遅いので、
こんな方法(辞書に検索データをリストしておく)を使うと
効率よくなります。

Sub Try1()
 Dim i As Integer, k As Integer
 Dim LstR1 As Long, LstR2 As Long
 Dim WS1 As Worksheet, WS2 As Worksheet
 Dim dic As Object
 Dim v
 
 Set dic = CreateObject("Scripting.Dictionary")
 Set WS1 = ThisWorkbook.Worksheets(1)
 Set WS2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx")
 
 '始めに Book1の現在のデータをDictionary(辞書)に登録しておく
 With WS1
   LstR1 = .Cells(.Rows.Count, 1).End(xlUp).Row
   v = .Range("A1:A" & LstR1).Value
   For k = 1 To UBound(v)
     dic(v(k, 1)) = Empty
   Next
 End With
 With WS2
   LstR2 = .Cells(.Rows.Count, 1).End(xlUp).Row
   v = .Range("A1:A" & LstR2).Value
   For k = 1 To UBound(v)
     'ws2のデータが辞書になかったら、転記する
     If Not dic.Exists(v(k, 1)) Then
       LstR1 = LstR1 + 1
       WS1.Cells(LstR1, 1).Value = v(k, 1)
     End If
   Next
 End With
 
End Sub

転記するデータをいったん配列に入れておき、
最後に一括して シートに転記するようにすれば、
もっと速く処理できますけど。

【71167】Re:異なるデータを抽出させる
質問  PePe  - 12/2/3(金) 11:29 -

引用なし
パスワード
   ▼kanabun さん:
ありがとうございます。
Findは次の段階で勉強したいと思います。
とりあえず、この種のコードをどのように書けば良いかと苦慮しています。

ご指摘のようにコードを変更しましたが…
Book1のA列1行目からAAA、BBB、CCC
Book2のA列1行目からAAA、BBB、CCC、KKK
としまして「KKK」が対象となって引き出せると良いのですが

コードを直してみました
Dim i As Integer, k As Integer
 Dim LstR1 As Long, LstR2 As Long, Bk1, Bk2
  Set Bk1 = ThisWorkbook
  Set Bk2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx")
 
   With Bk1.Worksheets("sheet1")
   LstR1 = .Cells(Rows.Count, 1).End(xlUp).Row
   LstR2 = Bk2.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
   For k = 1 To LstR2
   For i = 1 To LstR1
     If .Cells(k, 1) <> Bk2.Sheets("sheet1").Cells(i, 1) Then
      Exit For
     End If
   Next i
     Bk2.Sheets("sheet1").Cells(i, 1).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
   Next k
   If k > LstR2 Then
   End If
   
   End With
   Bk2.Close True
   Bk1.Save

ご指摘いただければ幸いです

【71168】Re:異なるデータを抽出させる
発言  Hirofumi  - 12/2/3(金) 11:31 -

引用なし
パスワード
   こんなのでは?

Sub Test()
 
'  Dim i As Integer, k As Integer
  Dim i As Long, k As Long
  Dim LstR1 As Long, LstR2 As Long, Bk1 As Workbook, Bk2 As Workbook
 
  Set Bk1 = ThisWorkbook
  Set Bk2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx")
  
  With Bk1.Worksheets("sheet1")
    LstR1 = .Cells(Rows.Count, 1).End(xlUp).Row
    LstR2 = Bk2.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
'    For k = 1 To LstR1
'      For i = 1 To LstR2
'        If .Cells(k, 1).Value <> Bk2.Sheets("sheet1").Cells(i, 1).Value Then
'          Exit For
'        End If
'      Next i
'    Next k
'    If k > LstR2 Then
'      Bk2.Sheets("sheet1").Cells(i, 1).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
'    End If
    For i = 1 To LstR2
      For k = 1 To LstR1
        If .Cells(k, 1).Value = Bk2.Sheets("sheet1").Cells(i, 1).Value Then
          Exit For
        End If
      Next k
      If k > LstR1 Then
        Bk2.Sheets("sheet1").Cells(i, 1).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
      End If
    Next i
  End With
  
  Bk2.Close True
  Bk1.Save

End Sub

【71169】Re:異なるデータを抽出させる
発言  kanabun  - 12/2/3(金) 11:32 -

引用なし
パスワード
   失礼

> Set WS1 = ThisWorkbook.Worksheets(1)
> Set WS2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx")
   ↓
  Set WS2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx").Worksheets(1)
または
  Set Bk2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx")
  Set WS2 = Bk2.Worksheets(1)

などに変更してください。

【71170】Re:異なるデータを抽出させる
発言  Hirofumi  - 12/2/3(金) 11:57 -

引用なし
パスワード
   Book2のA列を上から見て行きます
Book2のA列を1つ取り出し
Book1のA列と上から取り出した値を比較して行きます
もし、値が同じなら此れ以降比較する意味が無いので
Forを抜けます(Exit For)、この時、内側のループカウンタkは止まりますので
kの値は1以上、LstR1以内の値に成ります
また、内側のループを最後まで回り切った場合(比較した値が全て等しく無かった時)は
ループカウンkの値は「k > LstR1」と成ります
故に、内側のループの後に「If k > LstR1 Then」とすれば
取り出したBook2のA列の値が、Boo1に有ったか無かったかを判定する事が出来ます

【71171】Re:異なるデータを抽出させる
発言  kanabun  - 12/2/3(金) 11:59 -

引用なし
パスワード
   ▼PePe さん:

>Findは次の段階で勉強したいと思います。
>とりあえず、この種のコードをどのように書けば良いかと苦慮しています。

ある値が、ある範囲にあるかをLoopで範囲内の個々のセルにアクセスして
比較していくのは ばかサーチといって コードが難しいし、なによりセル
アクセスが頻繁に発生するのっで重い処理になります。
Findメソッドのほうがまだましです。コードも(内側のLoopがない分)
簡単になります。

Sub Findてすと() '------ Bk2の値が Bk1にあるか Find で調べる
 Dim i As Integer, k As Integer
 Dim LstR1 As Long, LstR2 As Long
 Dim Bk1 As Workbook, Bk2 As Workbook
 Dim v '←◆追加
 Dim r1 As Range '←◆追加
 Dim r2 As Range '←◆追加
 Dim c As Range '←◆追加
 
  Set Bk1 = ThisWorkbook
  Set Bk2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx")

  With Bk1.Worksheets("sheet1")
   LstR1 = .Cells(Rows.Count, 1).End(xlUp).Row
   Set r1 = .Range("A1:A" & LstR1)
   LstR2 = Bk2.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
   'Bk2シートA列をLoop
   For Each r2 In Bk2.Sheets("Sheet1").Range("A1:A" & LstR2)
     v = r2.Value
     Set c = Nothing
     'Bk2シートA列のあるセル値が、Bk1側にあるか調べる
     Set c = r1.Find(v, LookIn:=xlFormulas, LookAt:=xlWhole)
     '↓無かった時の処理
     If c Is Nothing Then
       LstR1 = LstR1 + 1
       .Cells(LstR1, 1).Value = v
     End If
   Next r2
 End With
 
 Bk2.Close True
 Bk1.Save

End Sub

【71172】Re:異なるデータを抽出させる
発言  Hirofumi  - 12/2/3(金) 12:42 -

引用なし
パスワード
   後、ついでですが?

もし、Book1のA列とBook2のA列が共に昇順整列されているなら
もう少し速くする事が出来ます

尚、A列の値が半角英数以外の文字が入るなら
モジュール先頭に以下のコードを記述して下さい
(Excelの整列順とVBAの整列順が違う為)

Option Explicit
Option Compare Text 'これ


Sub Test_2()
 
'  Dim i As Integer, k As Integer
  Dim i As Long, k As Long
  Dim LstR1 As Long, LstR2 As Long, Bk1 As Workbook, Bk2 As Workbook
  Dim lngAppend As Long, lngStart As Long
 
  Set Bk1 = ThisWorkbook
  Set Bk2 = Workbooks.Open(ThisWorkbook.Path & "\Book2.xlsx")
  
  With Bk1.Worksheets("sheet1")
    LstR1 = .Cells(Rows.Count, 1).End(xlUp).Row
    lngAppend = LstR1 + 1
    LstR2 = Bk2.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    lngStart = 1
    For i = 1 To LstR2
      For k = lngStart To LstR1
        If .Cells(k, 1).Value = Bk2.Sheets("sheet1").Cells(i, 1).Value Then
          Exit For
        End If
      Next k
      If k > LstR1 Then
        Bk2.Sheets("sheet1").Cells(i, 1).Copy .Cells(lngAppend, 1)
        lngAppend = lngAppend + 1
      Else
        lngStart = k + 1
      End If
    Next i
  End With
  
  Bk2.Close True
  Bk1.Save

End Sub

【71173】Re:異なるデータを抽出させる
お礼  PePe  - 12/2/3(金) 15:47 -

引用なし
パスワード
   ▼kanabun さん:
 Hirofumi さん:

貴重な体験をさせていただきました。ありがとうございます。
一度に理解して、覚えられれば良いのですが、少しずつ進めていきます。


Hirofumiさん…ループカウントkに関しての理解が今一分りません。しかしこれを望んでいました。解説を何度も見てスッテップインしているのですが…kの値は「k > LstR1」の現象も理解が進まずの状態です。でもこれが知りたかったのです。丁寧な解説ありがとうございました、解説を何度か読んで理解を進めます。

kanabunさん…find関数の素晴らしさを体験しました、大体の感触つかめました、次回、同じようなエクセル操作が必要な時には、必ずテストさせていただき、記憶するようにします。
Set dic = CreateObject("Scripting.Dictionary")は良く見るのですが、理解ができないままです。重複をなくしてデータを抽出するときには、必ず出てきますが、その度に、コードを見ては物まねしています。エラーがでましたが、すぐに訂正を書いていただいており、ありがとうございました。


いずれにしましても、コードを書くことは難しいことですね。後、5年ほど勉強しようとかと思っています。
ありがとうございました。

【71175】Re:異なるデータを抽出させる
発言  kanabun  - 12/2/3(金) 17:04 -

引用なし
パスワード
   ▼PePe さん:
>kanabunさん…find関数の素晴らしさを体験しました、
厳密にいうと RangeオブジェクトのFindメソッド です。

ワークシート関数で思い出したのですが、
Findメソッドの代わりに ワークシート関数のCountIf を使っても
同じことができますね

  With Bk1.Worksheets("sheet1")
   LstR1 = .Cells(Rows.Count, 1).End(xlUp).Row
   Set r1 = .Range("A1:A" & LstR1)
   LstR2 = Bk2.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
   'Bk2シートA列をLoop
   For Each r2 In Bk2.Sheets("Sheet1").Range("A1:A" & LstR2)
     v = r2.Value
     'Bk2シートA列のあるセル値が、Bk1側にあるか調べる
     If WorksheetFunction.CountIf(r1, v) = 0 Then '◆ ここ
      '↓無かった時の処理
       LstR1 = LstR1 + 1
       .Cells(LstR1, 1).Value = v
     End If
   Next r2
 End With

【71176】Re:異なるデータを抽出させる
発言  kanabun  - 12/2/3(金) 18:29 -

引用なし
パスワード
   ▼PePe さん:
時間があったので、Findと CountIf と Dictionary とで、
どのくらい処理時間に差が出るのか、2つのシートに
2万行のランダム数値データを置いて、テストしてみました。

Option Explicit
Declare Function timeGetTime Lib "winmm.dll" () As Long
’// 2万行データの生成
Sub GenData()
  Const Lo = 1000, Hi = 9999
  Const MAX = 20000
  Dim i&
  Randomize
  ReDim v(1 To MAX, 1 To 1)
  For i = 1 To MAX
    v(i, 1) = Int((Hi - Lo + 1) * Rnd() + Lo)
  Next
  Cells(1).Resize(MAX).Value = v
End Sub

Sub test1_Find()
  Const MAX = 20000
  Dim WS1 As Worksheet
  Dim WS2 As Worksheet
  Dim r1 As Range, r2 As Range, c As Range
  Dim LstR1 As Long, LstR2 As Long
  Dim v
  Dim t&
  t = timeGetTime()
  
  Set WS1 = Worksheets(1)
  Set WS2 = Worksheets(2)
  With WS1
    LstR1 = MAX '.Cells(Rows.Count, 1).End(xlUp).Row
    Set r1 = .Range("A1:A" & LstR1)
    LstR2 = MAX ' WS2.Cells(Rows.Count, 1).End(xlUp).Row
    'WS2 A列をLoop
    For Each r2 In WS2.Range("A1:A" & LstR2)
      v = r2.Value
      Set c = Nothing
      'Bk2シートA列のあるセル値が、Bk1側にあるか調べる
      Set c = r1.Find(v, LookIn:=xlFormulas, LookAt:=xlWhole)
      '↓無かった時の処理
      If c Is Nothing Then
        LstR1 = LstR1 + 1
        .Cells(LstR1, 1).Value = v
      End If
    Next r2
  End With
 
  Debug.Print "Find", timeGetTime() - t
  
End Sub

Sub test2_CountIf()
  Const MAX = 20000
  Dim WS1 As Worksheet
  Dim WS2 As Worksheet
  Dim r1 As Range, r2 As Range
  Dim LstR1 As Long, LstR2 As Long
  Dim v
  Dim t&
  t = timeGetTime()
  
  Set WS1 = Worksheets(1)
  Set WS2 = Worksheets(2)
  With WS1
    LstR1 = MAX '.Cells(Rows.Count, 1).End(xlUp).Row
    Set r1 = .Range("A1:A" & LstR1)
    LstR2 = MAX ' WS2.Cells(Rows.Count, 1).End(xlUp).Row
    'WS2 A列をLoop
    For Each r2 In WS2.Range("A1:A" & LstR2)
      v = r2.Value
      'Bk2シートA列のあるセル値が、Bk1側にあるか調べる
      If WorksheetFunction.CountIf(r1, v) = 0 Then
      '↓無かった時の処理
        LstR1 = LstR1 + 1
        .Cells(LstR1, 1).Value = v
      End If
    Next r2
  End With
 
  Debug.Print "CountIf", timeGetTime() - t
  
End Sub

Sub test3_Dictionary()
  Const MAX = 20000
  Dim WS1 As Worksheet
  Dim WS2 As Worksheet
  Dim r1 As Range, r2 As Range
  Dim LstR1 As Long, LstR2 As Long
  Dim i&, v
  Dim dic As Object
  Dim t&
  t = timeGetTime()
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set WS1 = Worksheets(1)
  Set WS2 = Worksheets(2)
  With WS1
    LstR1 = MAX '.Cells(Rows.Count, 1).End(xlUp).Row
    v = .Range("A1:A" & LstR1).Value
    For i = 1 To UBound(v)
     dic(v(i, 1)) = Empty
    Next
   
    LstR2 = MAX ' WS2.Cells(Rows.Count, 1).End(xlUp).Row
    'WS2 A列をLoop
    v = WS2.Range("A1:A" & LstR2).Value
    For i = 1 To UBound(v)
     'Bk2シートA列のあるセル値が、Bk1の辞書にあるか調べる
      If Not dic.Exists(v(i, 1)) Then
      '↓無かった時の処理
        LstR1 = LstR1 + 1
        .Cells(LstR1, 1).Value = v(i, 1)
      End If
    Next i
  End With
 
  Debug.Print "Dictionary", timeGetTime() - t
  
End Sub

■結果です(1回だけ  単位:ミリ秒)
CountIf    69390

Find      59691

Dictionary   256

【71177】Re:異なるデータを抽出させる
発言  kanabun  - 12/2/3(金) 19:08 -

引用なし
パスワード
   >転記するデータをいったん配列に入れておき、
>最後に一括して シートに転記するようにすれば、
>もっと速く処理できますけど。

Sub test3_Dictionary2()
  Const MAX = 20000
  Dim WS1 As Worksheet
  Dim WS2 As Worksheet
  Dim r1 As Range, r2 As Range
  Dim LstR1 As Long, LstR2 As Long
  Dim i&, v, u, k&
  Dim dic As Object
  Dim t&
  t = timeGetTime()
  
  Set dic = CreateObject("Scripting.Dictionary")
  Set WS1 = Worksheets(1)
  Set WS2 = Worksheets(2)
  With WS1
    LstR1 = MAX '.Cells(Rows.Count, 1).End(xlUp).Row
    v = .Range("A1:A" & LstR1).Value
    For i = 1 To UBound(v)
     dic(v(i, 1)) = Empty
    Next
    ReDim u(1 To UBound(v), 1 To 1)
    LstR2 = MAX ' WS2.Cells(Rows.Count, 1).End(xlUp).Row
    'WS2 A列をLoop
    v = WS2.Range("A1:A" & LstR2).Value
    For i = 1 To UBound(v)
     'Bk2シートA列のあるセル値が、Bk1の辞書にあるか調べる
      If Not dic.Exists(v(i, 1)) Then
      '↓無かった時の処理
        k = k + 1
        u(k, 1) = v(i, 1)
      End If
    Next i
    If k Then
     .Cells(LstR1 + 1, 1).Resize(k).Value = u
    End If
  End With
 
  Debug.Print "Dict_arry", timeGetTime() - t
  
End Sub

■上と同じ 2万行データの 結果です

Dict_arry   85

1895 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free