[[20151121130946]] 『重複の無いデータ行を取出し別シートへ取込む方法』(やっぱり初歩) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『重複の無いデータ行を取出し別シートへ取込む方法』(やっぱり初歩)

 いつもお世話になっています。
 過去ログで有ればいいのですが見つけ出せず困っています。

 Sheet2(A)に追加されたデータが有れば、Sheet(B)へ行全体を取込みたいのですが上手くいきません。
 問題点
  1)最初から全くダメで(B)に有るものでも抽出される。
  2)直ぐに「インデックスが有効ではありません」のエラーとなる。

  何が悪いのかも分かりません。基本が分かっていない事は承知しています。

 関連する3枚のシートを一度に処理でしたいのです。
 データ数は最大1万件で、フィールド数は6個から20個です。以下がその内容です。

 Sub Test()
 Dim sDic As Object, mDic As Object
 Dim c As Range
 Dim v As Variant, w As Variant
 Dim Rn1 As Long, Rn2 As Long, Cn As Long
 Dim i As Long, j As Long, k As Long, p As Long, x As Long

    Set sDic = CreateObject("Scripting.Dictionary")      '受け側用
    Set mDic = CreateObject("Scripting.Dictionary")      '送り側用

    With Sheets("Sheet1").Range("A1")
       Rn1 = .CurrentRegion.Rows.Count
       Cn = .CurrentRegion.Columns.Count
       For i = 1 To Rn1 - 1
          sDic(.Offset(i).Value) = .Offset(i).Value & .Offset(i, 2).Value
       Next
    End With

    With Sheets("Sheet2").Range("A1")
       Rn2 = .CurrentRegion.Rows.Count - 1
       Cn = .CurrentRegion.Columns.Count
       ReDim v(1 To Cn)

       For j = 2 To Rn1
          For k = 1 To Rn2
             w = .Offset(k).Value

             'チェック。既にここから間違っている。
             If Not sDic.Exists(.Offset(k).Value & .Offset(k, 2).Value) Then
                x = x + 1
                For p = 1 To Cn                    'このForが終わるまで問題ない
                   v(p) = .Offset(j, p - 1).Value
                Next
                mDic.Add w, v()                    '←ここで配列Vを追加★
             End If                                '結果は「インデックスが有効ではありません」?
          Next
       Next
    End With

 End Sub

 何とも判りません。何卒ご指導の程お願いします。

< 使用 Excel:Excel2013、使用 OS:Win10 >

 −追記-
[[20151119153508]] でも同じ様な質問ですが、セルに沢山の関数埋込も大変。
 その前にシート関数の使い方が良く分からないのです。

mDic(w) = vでどうなりますか?

その他、よく考えていませんが、気になった点は

 >For j = 2 To Rn1
 は必要?

 >w = .Offset(k).Value
 w = .Offset(k).Value & .Offset(k, 2).Value	じゃありませんか?

そもそもですが、全部転記して重複の削除が一番楽ちんな気がします。

(マナ) 2015/11/21(土) 14:34


 よく全体を読んでいないのですが、

 mDic.Add w, v()                    '←ここで配列Vを追加★
                                    '結果は「インデックスが有効ではありません」?

 この Addメソッドで インデックスが有効ではない というエラーはでないと思いますが?
 エラーになるなら、メッセージは このキーはすでにコレクションに 云々 というものではなかったですか?

 いずれにしても、DictionaryのAddメソッドは、使う意味がほとんどないシロモノだと思っています。
 マナさん指摘のように キーを与えて Itemプロパティに直接セットするのがよろしいかと。
 (同じキーの場合は上書き)

(β) 2015/11/21(土) 15:11


Dim v() As Variantでもよいです。
ただし、βさんのコメントの通り、ADDのままだと別のエラーが出る可能性がでてきます。
(マナ) 2015/11/21(土) 15:25

 >>関連する3枚のシートを一度に処理でしたいのです。

 3枚のシートというのが ?? ですが、以下は Sheet1 の A列の値が Sheet2 のA列になければ
 Sheet1の、その行を SHeet2 の末尾に追加します。
 1万件ということなので、処理時間が気になりますが、あまりに遅いようであれば、チューニングします。

 Sub Sample()
    Dim c As Range
    Dim dicB As Object
    Dim shT As Worksheet
    Dim i As Long
    Dim r As Range

    Application.ScreenUpdating = False

    Set shT = Sheets("Sheet2")
    Set dicB = CreateObject("Scripting.Dictionary")

    With shT.Range("A1", shT.Range("A" & Rows.Count).End(xlUp))
        i = .Rows.Count + 1 '転記開始行
        For Each c In .Cells
            dicB(c.Value) = True
        Next
    End With

    With Sheets("Sheet1")
        With .Range("A1", .UsedRange)
            For Each r In .Rows
                If Not dicB.exists(r.Cells(1).Value) Then
                    r.Copy shT.Cells(i, "A")
                    i = i + 1
                End If
            Next
        End With
    End With

    shT.Select

 End Sub

(β) 2015/11/21(土) 15:28


 もう一例アップしておきます。
 そちらの実際のデータで処理した場合、どちらが早いか(あるいはどちらも遅いか)わかりませんが。

 Sub Sample2()
    Dim dicA As Object
    Dim c As Range
    Dim r As Range
    Dim x As Long
    Dim z As Long

    Application.ScreenUpdating = False

    Set dicA = CreateObject("Scripting.Dictionary")

    With Sheets("Sheet1")
        With .Range("A1", .UsedRange)
            x = .Columns.Count
            For Each r In .Rows
                dicA(r.Cells(1).Value) = r.Value
            Next
        End With
    End With

    With Sheets("Sheet2")
        With .Range("A1", .Range("A" & Rows.Count).End(xlUp))
            z = .Rows.Count + 1 '転記開始行
            For Each c In .Cells
                If dicA.exists(c.Value) Then dicA.Remove (c.Value)
            Next
        End With
        If dicA.Count > 0 Then
            .Cells(z, "A").Resize(dicA.Count, x).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicA.items))
        End If
        .Select
    End With

 End Sub

(β) 2015/11/21(土) 16:09


マナさん、βさん 早速のご指摘ありがとうございます。

 実はこの事で昨日から悩んでいて解決方法を見出せななく疲労困憊でした。
 マナさんご指摘の『mDic(w) = vでどうなりますか? 』もやりましたがダメでした。

 所用から帰宅しPCを立ち上げてやり直したら何ら問題ありませんでした。    ???です。
 尚、前回までのエラーメッセージは「インデックスが有効ではありません」でした。
 >そもそもですが、全部転記して重複の削除が一番楽ちんな気がします。
  私もその方が良いのではと思ったのですが、迷った末の選択でした。試行しなくて・・・

 この処理方法の前に、Removeduplicatesで試行しましたがこれも問題が発生して処理が出来ず頓挫。
 その失敗理由は、このメソッドではデータは確保されるのですが事前設定のセル書式で入らずに
 まるで書式を初期化した状態で埋め込まれました。罫線等も無くなってしまったのです。
 しかし処理速度は速いでですね。

 βさんが感じられたデータ件数の事ですが、現在テストで200〜300レコードでも私のコードでは
 時間が掛かり過ぎの様に思いました。

 今の私には疲れの為理解するには時間が必要です。
 後ほど連絡します。不明な点も出て再質問となると思いますが・・・
(やっぱり初歩) 2015/11/21(土) 16:23

 追記
 いつも不思議に思う事があります。βさんのコードを見ていると私のとは全く違います。
宣言する変数の数が全く少なく、本当に見易いコードとなっています。
私などは自分が理解できない為沢山の変数を用意する必要があります。
然し、自分で良く分からなくなる事が多々あります。資質が悪くても勉強ですね。


 あぁ、罫線など書式も含めてコピーという要件でしたか。
 私のアップしたSample2のほうは値だけのコピーになっています。

(β) 2015/11/21(土) 17:07


重複の削除の場合、骨格はこんな感じです。
A列とB列で重複判定しています。
 Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    Application.ScreenUpdating = False

    ws1.Range("a1").CurrentRegion.Copy ws2.Range("a" & Rows.Count).End(xlUp).Offset(1)
    ws2.Range("a1").CurrentRegion.RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    ws2.Select

 End Sub

(マナ) 2015/11/21(土) 18:24


 ご提示して頂きましコードは大方理解出来ました。有難うございます。 

 前文が説明不足で申し訳ありません。罫線を含めた書式コピーというのではなく、値だけのコピーで良いのです。
 私がやろうとしたのは他のブックからデータ取出しを行う時、同時に重複があるかをチェックし新規のもの
だけを追加する事でした。

 ブック同士は全く同型としたのですが、何の間違いか、単に取込んだだけで罫線以外の書式が初期化され、
 更にはRemoveduplicatesで重複削除をすると今度は罫線が消去されるといった具合でした。

 1)ブックA.シート1.範囲=ブックB.シート1.範囲.Value という感じでデータ転記した時の現象。
   ブックAをコピーして作成したブックBですが、この様な事はダメなんでしょうか?

 2)やはりRemoveduplicatesを使った場合で重複の有った部分はオールクリヤされるのでしょうか?

 最初の質問と若干異なってきました。今日1日あれやこれと試行するも上手く行かずでした。

 関連する3枚のシート:
  ・商品コード       (商品追加等が多々あり。単価等情報含む)
  ・個別の1か月の売上明細 (日付、数量等他その時々の情報も)
  ・個別の1か月間の集計。 (集計だけではない為、このシートは20項目ほどあり)
 といった内容です。ちょっと無駄があるかもしれませんが。

 どうぞ宜しくお願いします。

(やっぱり初歩) 2015/11/21(土) 20:27


転記先をテーブルに設定しておくのはどうでしょうか

  Sub test2()
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    Application.ScreenUpdating = False

    ws1.Range("a1").CurrentRegion.Copy ws2.Range("a" & Rows.Count).End(xlUp).Offset(1)
    ws2.Range("テーブルの名前").RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo
    ws2.Select

 End Sub

(マナ) 2015/11/21(土) 20:46


 マナさんへ
  すみません。分かっている様で分かっていませんでした。
 Test1は問題でなかったのですが『テーブルの名前』がいるTest2では失敗となりました。
 『プロシージャの呼び出し、又は引数が不正です』となりました。
 『テーブルの名前』とは名前の管理で1個のセルにしたのがいけないのでしょうか?範囲なのでしょうか?

 そして、Removeduplicatesでは罫線から書式まで重複があった範囲はクリヤされるのですね。

 βさんへ
 重複検索条件が2列(若しくはそれ以上)の場合はどの様にしたらいいのでしょうか。
 私の場合は1列目と3列目となっています。

     With Sheets("Sheet1")
         With .Range("A1", .UsedRange)
             x = .Columns.Count
             For Each r In .Rows
                 dicA(r.Cells(1).Value) = r.Value
             Next
         End With
     End With

 の1段目は適当に dicA(r.Cells(1).Value & r.Cells(1,3) = r.Value
 で動作するのですが、2段目も同じようにしたらエラーです。
 『アプリケーションの定義エラー、若しくはオブジェクトの定義エラーです』と出ます。

 分からないまま試行しましたが、やっぱり初歩です。
 質問する前に想像でレコード(行)操作だからRowsが使えないと考えましたが使い方が
 全く分からず断念していました。覚えれば今後何かの時のヒントになるかと思っています。
 どうぞよろしくお願いsます。

(やっぱり初歩) 2015/11/21(土) 22:53


Sheet2のデータ範囲をテーブルに設定してください
http://www4.synapse.ne.jp/yone/excel2013/excel2013_table_settei.html

 >Removeduplicatesでは罫線から書式まで重複があった範囲はクリヤされるのですね。

 そのようです。

 で、テーブルにしておくと事前に書式設定しておかなくても、
 追加された部分に同じ書式が適用されるようです。

(マナ) 2015/11/21(土) 23:24


 マナさんへ
 真に申し訳ありません。テーブルを一度も使ったことがありません。当然便利さも分かりません。
 私のエクセル感覚はXL2003の延長なので新機能も殆ど使わずじまいでした。

 明日はボランティア活動で1日中いません。明後日に取組んでみます。やや酒が入った今の状態
 では申し訳ありませんから…  有難うございました。
(やっぱり初歩) 2015/11/21(土) 23:44

 検索条件に対する追加の質問です。

 CreateObject処理:
  2列での条件の内、片方が日付の場合にはどの様にしたらいいのか?
  出来るのであれば知りたいと思いました。

 ※期間(1か月)も条件としたら速度向上が図れるのではと考えた次第です。
  しかし、この考えは無駄なんでしょうか。検索に対する縛りが増えるから?

 マナさんへ
 再確認です。テーブルの設定をした場合の書式の維持は基本的な部分で、
 罫線やセル内のインデント、そしてIDだけ太字にという設定も初期化
 されました。
 (この部分に対しては特に拘る必要が無いのですが、残れば良いかな位)

 朝早くからの質問ですみません。宜しくお願いします。

(やっぱり初歩) 2015/11/22(日) 05:17


マナさんへ

 すみません。私のミスでした。送り側の設定が間違っていました。(設定なし状態だった)
 きっちりと書式も維持されました。有難うございます。
(やっぱり初歩) 2015/11/22(日) 05:50

 【1段目】とか【2段目】の意味がわかりませんけど、一般論でいいますと、
 複数のセルの値をキーにする場合は、それらセルを連結させたものを使えばOKです。

 セルA & セルB & セルC とか。

 ただ、単純に連結すると、

 AA と AAAA --> AAAAAA
 AAA と AAA  --> AAAAAA

 このように同じ値になってしまうリスクがありますので、文字列に現れない(だろう)文字を間に挟みこむことが多いです。

 セルA & vbTab & セルB & vbTab & セルC とか。 

 ただ、個別の話でいうと【1段目】とか【2段目】がわからないのでコメントしづらいです。

 キーとして A列に加えて C列も ということなら dicA(r.Cells(1).Value & vbTab & r.Cells(1,3)) = r.Value ですね。
 今回の場合、 r は 1行の領域ですから、その領域の〇番目という書き方ができますので、
 dicA(r.Cells(1).Value & vbTab & r.Cells(3)) = r.Value でもいいですが。

 で、一方が日付の場合という質問ですが、日付であっても、何であっても、基本はかわりません。
 それで速度が改善するかどうか、それはそれによって処理回数が減るかどうかという要件次第ですので
 なんともいえません。
 ただしい、今回のテーマ、「ユニークかどうかのチェック」というポイントから見て、日付を加えなければユニークにならないのであれば
 日付追加は必須でしょうね。
 A列だけでユニークなのであれば日付追加は無駄でしょうし。(というか、後でコードを見たときに、なぜ日付もキーなの? と混乱する)

(β) 2015/11/22(日) 06:01


 早朝にコメント頂き有難うございます。

 文字に現れない文字。以前にAutoFilterを利用する時にVbCrLFを使用したのと同じような感覚ですね。
 これも区切り文字という事でしょうか。

 >dicA(r.Cells(1).Value & vbTab & r.Cells(3)) = r.Value
  後で気づいたのですが1行分の処理だからカラムの部分は不要ではと思っていました。
 > A列だけでユニークなのであれば日付追加は無駄でしょうし。
  日付も絡めないとユニークにならないので必要です。

 >【1段目】とか【2段目】:特に意味がありません。単に区別したかっただけです。
   1段目=受側を配列への格納作業(Or渡し側)
   2段目=重複チェック

 有難うございました。これから出掛けます。ボランティア活動です。 

(やっぱり初歩) 2015/11/22(日) 07:31


 一段目、二段目 了解です。
 アップした2つのマクロ、以下のようになりますね。
 Sampleのように直接記述してもいいですし、Sample2のように別途変数を準備して、そこに格納した上で利用する方法もあります。

 Sub Sample()
    Dim c As Range
    Dim dicB As Object
    Dim shT As Worksheet
    Dim i As Long
    Dim r As Range

    Application.ScreenUpdating = False

    Set shT = Sheets("Sheet2")
    Set dicB = CreateObject("Scripting.Dictionary")

    With shT.Range("A1", shT.Range("A" & Rows.Count).End(xlUp))
        i = .Rows.Count + 1 '転記開始行
        For Each c In .Cells
            dicB(c.Value & vbTab & c.Offset(, 2).Value) = True  '★
        Next
    End With

    With Sheets("Sheet1")
        With .Range("A1", .UsedRange)
            For Each r In .Rows
                If Not dicB.exists(r.Cells(1).Value & vbTab & r.Cells(3).Value) Then    '★
                    r.Copy shT.Cells(i, "A")
                    i = i + 1
                End If
            Next
        End With
    End With

    shT.Select

 End Sub

 Sub Sample2()
    Dim dicA As Object
    Dim c As Range
    Dim r As Range
    Dim x As Long
    Dim z As Long
    Dim k As String         '★

    Application.ScreenUpdating = False

    Set dicA = CreateObject("Scripting.Dictionary")

    With Sheets("Sheet1")
        With .Range("A1", .UsedRange)
            x = .Columns.Count
            For Each r In .Rows
                k = r.Cells(1).Value & vbTab & r.Cells(3).Value '★
                dicA(k) = r.Value                               '★
            Next
        End With
    End With

    With Sheets("Sheet2")
        With .Range("A1", .Range("A" & Rows.Count).End(xlUp))
            z = .Rows.Count + 1 '転記開始行
            For Each c In .Cells
                k = c.Value & vbTab & c.Offset(, 2).Value       '★
                If dicA.exists(k) Then dicA.Remove k            '★
            Next
        End With
        If dicA.Count > 0 Then
            .Cells(z, "A").Resize(dicA.Count, x).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicA.items))
        End If
        .Select
    End With

 End Sub

(β) 2015/11/22(日) 08:25


βさん
有難うございました。今回の疑問は完全に解決出来ました。

 只、今までも疑問というか不可思議というか良く分からず、又、便利に扱っていたセル 自身の事なのですが、

 > k = c.Value & vbTab & c.Offset(, 2).Value       '★ k As String
 > dicA(k) = r.Value                '★ 右辺は配列と理解

 例えば上の記述の様に時にセル内は文字、時には数値、時には数値でも時間だったのりバリアントなので
 扱う時にその便利さにかまけて適当にしていると問題を生じさせたりします。
 一時、2つのセルを繋げる場合に Cstr(Range("A1")) & Cstr(Range("A2")) 等と生真面目にしていました。
 フォームのテキストボックスでも似たように思います。今は慣れで適当に扱う事が多いのですが…

(やっぱり初歩) 2015/11/22(日) 20:09


 確かに心配になるかもしれません。
 が、安心していいです。
 基本的に VBA で 代入先変数 = 代入元の値 を実行すると、右辺のデータ型が何であっても
 自動的に、代入先変数のデータ型に変換されます。
 以下に、そのあたりの組み合わせを何種類かコード化しましたので参考にしてください。

 なお、テクストボックスの値は、それが数字であれ、文字であれ、すべて 「文字列型:String」です。

 Sub TestN1()
    Dim d1 As Long
    Dim d2 As Long
    Dim n As Long
    Dim s As String

    d1 = "123"
    d2 = "456"

    n = d1 & d2
    s = d1 & d2

    MsgBox n & vbLf & TypeName(n)
    MsgBox s & vbLf & TypeName(s)

 End Sub

 Sub TestN2()
    Dim d1 As Long
    Dim d2 As Long
    Dim n As Long
    Dim s As String

    d1 = 123
    d2 = 456

    n = d1 & d2
    s = d1 & d2

    MsgBox n & vbLf & TypeName(n)
    MsgBox s & vbLf & TypeName(s)

 End Sub

 Sub TestS1()
    Dim d1 As String
    Dim d2 As String
    Dim n As Long
    Dim s As String

    d1 = "123"
    d2 = "456"

    n = d1 & d2
    s = d1 & d2

    MsgBox n & vbLf & TypeName(n)
    MsgBox s & vbLf & TypeName(s)

 End Sub

 Sub TestS2()
    Dim d1 As String
    Dim d2 As String
    Dim n As Long
    Dim s As String

    d1 = 123
    d2 = 456

    n = d1 & d2
    s = d1 & d2

    MsgBox n & vbLf & TypeName(n)
    MsgBox s & vbLf & TypeName(s)

 End Sub

(β) 2015/11/22(日) 21:05


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.