[[20181019154122]]　『特定文字を含む行を別シートにコピー・重複データ』（まる）　ページの最後に飛ぶ

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

　

『特定文字を含む行を別シートにコピー・重複データを上書き』（まる）

sheet1にはA~K列（行は不特定）まで情報が入っています（1行目は項目）。
Sheet1のH列に「企業」と入っている行をコピーし、Sheet2の2行目以降に貼り付けをしようと思っています。
Sheet2のフォーマット（列数・項目）はSheet1と一緒です。

貼り付けの際に重複するデータ（行）は上書きするような形にしたいのですが
今のマクロだと重複データも貼り付けされてしまいます。

Sub 訪問データ() 

    Dim wbRead As Workbook
    Dim wbOut As Workbook
    Dim shtRead As Worksheet
    Dim shtOut As Worksheet


    Set wbRead = ActiveWorkbook
    Set wbOut = Workbooks("あいう.xlsm")
    Set shtRead = wbOut.Worksheets("sheet1")
    Set shtOut = wbOut.Worksheets("sheet2")


    Dim rng As Range
    Dim lastRow As Long


    For Each shtRead In wbRead.Worksheets
         For Each rng In shtRead.Range(shtRead.Cells(8, 1), shtRead.Cells(shtRead.Rows.Count, 1).End(xlUp))
            'H列が訪問
            If shtRead.Cells(rng.Row, 8) = "訪問" Then
            shtRead.Rows(rng.Row).Copy


                Dim KENSAKU As Variant
                KENSAKU = shtRead.Range("A:K")
                Dim FoundCell As Range
                Set FoundCell = shtOut.Range("A:K").Find(What:=KENSAKU, LookAt:=xlWhole)


                If FoundCell Is Nothing Then                    lastRow = shtOut.Cells(Rows.Count, 1).End(xlUp).Row + 1


                    shtOut.Rows(lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False


                Else


 shtOut.Rows(FoundCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False


                End If
            End If
        Next rng
    Next shtRead


    Application.CutCopyMode = True
    ActiveCell.Select

End Sub

間違いが分からないため、ご教示下さい。

＜ 使用 Excel：Excel2010、使用 OS：Windows8 ＞

 ＞   KENSAKU = shtRead.Range("A:K")
 ＞   Set FoundCell = shtOut.Range("A:K").Find(What:=KENSAKU, LookAt:=xlWhole)
この部分がよく判りません。 元シート全部を先シート全部から探す…。変ですよね？
今調べている行は rng で判るので、その行にあるどれかの情報を出力先から探しましょう。
（???） 2018/10/19(金) 16:20
???さん

検索してヒットしたマクロを拾って当てはめたので、マクロの意味?が分かっていない状況です。
???さんがから指摘していただいたマクロの意味がわからないのでどこが変かわかりませんでした…。

（まる） 2018/10/19(金) 16:40

こんな手順だと簡単では？
手作業でもできるくらい

１）sheet1のH列が「企業」をオートフィルタ
２）sheet2に転記
３）「重複の削除」実行
４）オートフィルタ解除

（マナ） 2018/10/19(金) 19:04

フィルタオプションでもできるかもしれません。

１）Sheet2のデータをsheet1のデータの下に転記
２）フィルタオプションで、H列が「企業」の行を重複なしでsheet2に転記
３）１）で転記したデータをクリア

（マナ） 2018/10/19(金) 20:17

マナさん

フィルターで作業をするのではなく、不特定多数の方が使うシートなので、
ボタンをクリックする作業で済ませたいです＞＜
（まる） 2018/10/22(月) 13:21

コードだと、A:Kセルから探す事になっているし、探す文字は「訪問」のようですが、実際はどうなのでしょう？ 最初の質問だと、H列から「企業」を探そうとしているように見えるのですが。

やりたいことと違う事をコーディングしても思った通りに動く訳がないです。 まずは H:H セルから「企業」を探すように書き換えてみてください。（KENSAKUしたいのは "企業" なのでしょう？）
（???） 2018/10/22(月) 14:07

???さん
「訪問」で検索をかけてヒットした行をシート２へ貼り付けしたいです。
マクロをボタンに張り付けているのですが、ボタンを何度もクリックした際に
重複データがペーストされてしまうと思うので、それを解消したいのですが＞＜
（まる） 2018/10/22(月) 14:26
 >貼り付けの際に重複するデータ（行）は上書きするような形にしたいのですが 
 >今のマクロだと重複データも貼り付けされてしまいます。
 この「重複するデータ」とは具体的に何が何に対しての重複でしょう？

（seiya） 2018/10/22(月) 14:48

ｓｅｉｙａさん
コマンドボタンを押すとシート１のデータ（Ａ～Ｋ）をシート２にペーストするようにしたいのですが、
コマンドボタンを押すたびにシート１の１行目～最終データ入力行がシート２の最終行にペーストされてしまいます。

シート１もデータも他ブックから抽出した情報を反映させています。
抽出ボタンを押すと自動でブックから拾ってくるようになっているのですが、こちらも同様にボタンを押すたびに元データの1行目から反映されてしまいます~~;
（まる） 2018/10/22(月) 14:58

ステップ実行すれば判る事ですが、検索して何も見つからないので、If FoundCell Is Nothing Then の方に行ってしまい、追記になっているのですよ。 だから、検索して見つかるようにしないと駄目です。 検索する列と、検索する文字列。 まずはこれを正してください。

だけど、H列が「訪問」なのだとして、それって沢山の行に同じ文字列がありませんか？ 同じ行なら上書き、を実現するならば、探すべきなのは、ユニークな文字列にしないと駄目ですよ。
（???） 2018/10/22(月) 15:05

 ループ開始する前に既存ののデータをクリアる。


 ということですか？


 shtOut.Cells(1).CurrentRegion.Offset(1).Clear


 とか？
（seiya） 2018/10/22(月) 15:13
???さん
＞H列が「訪問」なのだとして、それって沢山の行に同じ文字列がありませんか？
その通りです。
・Ｈ列で「訪問」行を検索し、コピー
・シート２のＡ～Ｋ列でコピーした訪問行と一致する行はないか検索、あれば上書き、なければ最終行に追記
としたいのですが＞＜
（まる） 2018/10/22(月) 15:23
seiyaさん
データクリアはしません。
データを重複がないように追記させていきたいです。
（まる） 2018/10/22(月) 15:24
 >データを重複がないように追記させていきたいです。
 これがよくわからいのですよね...


 具体的に例を挙げて説明してもらった方が理解しやすいと思いますが？
（seiya） 2018/10/22(月) 15:27
seiyaさん
説明が不十分ですみません＞＜
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

他ブックより転記すると例えばこのようなデータが抽出されたとします。
～シート１～ 

    A    B    C    D    E    F     G     H    I    J    K
1 aaa  bbb  ccc   ddd  eee  fff  ggg   訪問  iii  jjj  kkk
2 abc  def  ghi   jkl  mno  pqr  stu   wxy   zab  cde  fgh
3 zyx  uts  rqp   mno  jkl  ihg  fed   cba   aba  bcb  cdc
4 aaa  bbb  ccc   fff  ggg  aba  aab   訪問　bbc  ccd  dde

H列で「訪問」と入力されている行をシート２へ抽出します。
～シート２～ 

    A    B    C    D    E    F     G     H    I    J    K
1 aaa  bbb  ccc   ddd  eee  fff  ggg   訪問  iii  jjj  kkk
2 aaa  bbb  ccc   fff  ggg  aba  aab   訪問　bbc  ccd  dde
3 
4

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

★シート１に新しいデータが更新され、以下のデータになったとします。
～シート１～ 

    A    B    C    D    E    F     G     H    I    J    K
1 aaa  bbb  ccc   ddd  eee  fff  ggg   訪問  iii  jjj  kkk
2 abc  def  ghi   jkl  mno  pqr  stu   wxy   zab  cde  fgh
3 zyx  uts  rqp   mno  jkl  ihg  fed   cba   aba  bcb  cdc
4 aaa  bbb  ccc   fff  ggg  aba  aab   訪問　bbc  ccd  dde
5 lll  mmm  nnn   ooo  ppp  qqq  rrr   訪問  ttt  uuu  www

H列で「訪問」と入力されている行をシート２へ抽出します。
～シート２～ 

    A    B    C    D    E    F     G     H    I    J    K
1 aaa  bbb  ccc   ddd  eee  fff  ggg   訪問  iii  jjj  kkk
2 aaa  bbb  ccc   fff  ggg  aba  aab   訪問　bbc  ccd  dde
3 aaa  bbb  ccc   ddd  eee  fff  ggg   訪問  iii  jjj  kkk
4 aaa  bbb  ccc   fff  ggg  aba  aab   訪問　bbc  ccd  dde
5 lll  mmm  nnn   ooo  ppp  qqq  rrr   訪問  ttt  uuu  www

となってしまいます＞＜
３・４行目が1・2行目と重複してしまいます。

これを
～シート２～ 

    A    B    C    D    E    F     G     H    I    J    K
1 aaa  bbb  ccc   ddd  eee  fff  ggg   訪問  iii  jjj  kkk
2 aaa  bbb  ccc   fff  ggg  aba  aab   訪問　bbc  ccd  dde
3 lll  mmm  nnn   ooo  ppp  qqq  rrr   訪問  ttt  uuu  www
4
5

とするにはどうすればいいのでしょうか？

（まる） 2018/10/22(月) 15:45

 こういうことですか？


 Sub test()
     Dim ws1 As Worksheet, ws2 As Worksheet, x
     Set ws1 = Sheets("sheet1")
     Set ws2 = Sheets("sheet2")
     With ws1.Cells(1).CurrentRegion
         .Parent.AutoFilterMode = False
         .AutoFilter 8, "訪問"
         .Offset(1).Copy ws2.Range("a" & Rows.Count).End(xlUp)(2)
         .AutoFilter
     End With
     With ws2.Cells(1).CurrentRegion
         x = Evaluate("column(" & .Rows(1).Address & ")")
         ReDim Preserve x(0 To UBound(x) - 1)
         .RemoveDuplicates (x), 1
     End With
 End Sub
（seiya） 2018/10/22(月) 16:01
seiyaさん

思った通りのこができました！
ありがとうございます。
重複行をチェックし、削除するコードはどの部分になりますか？
他のコードにもくっつけてみたいのですが・・・
（まる） 2018/10/22(月) 16:11

     With ws2.Cells(1).CurrentRegion
         x = Evaluate("column(" & .Rows(1).Address & ")")
         ReDim Preserve x(0 To UBound(x) - 1)
         .RemoveDuplicates (x), 1
     End With


 ここで全列が重複している行を削除しています。
（seiya） 2018/10/22(月) 16:16
ありがとうございました＾＾
（まる） 2018/10/22(月) 16:25
seiyaさん
もう一つ質問があるのですが、よろしいでしょうか？
貼り付けをする際に値貼り付けにしたいのですが、
ペーストのコードはどの部分になるのでしょうか？
初歩的な質問ばかりで申し訳ないのですが、よろしくお願します＞＜
（まる） 2018/10/22(月) 17:04
 >         .Offset(1).Copy ws2.Range("a" & Rows.Count).End(xlUp)(2)
 を


         .Offset(1).Copy
         ws2.Range("a" & Rows.Count).End(xlUp)(2).PasteSpecial xlValues
 の2行に変更して下さい。
（seiya） 2018/10/22(月) 17:08
できました！
度々すみませんでした。
ありがとうございます。
（まる） 2018/10/22(月) 17:13
コメント返信：

[ 一覧(最新更新順) ]

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