• ベストアンサー

ExcelVBAでデータ不一致のものの抽出

単純なものにしたいので教えてください。 Sheet1「元データ」                  A   B    C   D   コード 商品  店名  納入日   1 0001 みかん  A店  3/1  5 0360 メロン  D店 6 かき   P店 7 0312 キウイ  D店 9 0333 くり C店 Sheet2「最新データ」   A   B    C   D コード 商品  店名  納入日  1 0001 みかん  A店  3/1 4 0311 いちご B店  3/10 6 0250 8 0312 キウイ    とあった時に元データのA列の番号と最新データの番号を見て同じ物があったら、元データに最新データの内容をうつし込み、一致しなかったらチェックデータへうつしこむというデータがあります。 Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh3 As Worksheet Dim myR As Range Dim N_D As Long Dim i As Long Set Sh1 = Worksheets("元データ") Set Sh2 = Worksheets("チェックデータ") Set Sh3 = Worksheets("最新データ") With Sh1 For i = 5 To .Range("A65536").End(xlUp).Row N_D = .Range("E" & i).Value Set myR = Sh3.Range("A:A").Find(What:=N_D, LookIn:=xlValues, _ MatchCase:=False) If Not myR Is Nothing Then myR.Offset(, 2).Resize(, 3).Copy _ Destination:=.Range("B" & i & ":D" & i) Else addR_No = Sh2.Range("A65536").End(xlUp).Row + 1 .Range("A" & i & ":D" & i).Copy _ Destination:=Sh2.Range("A" & addR_No & ":D" & addR_No) End If Next End With ここで、データが一致した場合は無視して、一致しなかったときだけチェックデータに内容を書き込むとする場合はどのように修正すればよいのでしょうか?あと、チェックデータのあたまに コード 商品  店名  納入日  という言葉を入れたいのですが、どのように書き込むのでしょうか?

質問者が選んだベストアンサー

  • ベストアンサー
noname#29107
noname#29107
回答No.1

>ここで、データが一致した場合は無視して、一致しなかったときだけチェックデータに >内容を書き込むとする場合はどのように修正すればよいのでしょうか? If Not myR Is Nothing Then   myR.Offset(, 2).Resize(, 3).Copy _   Destination:=.Range("B" & i & ":D" & i) Else   addR_No = Sh2.Range("A65536").End(xlUp).Row + 1   .Range("A" & i & ":D" & i).Copy _   Destination:=Sh2.Range("A" & addR_No & ":D" & addR_No) End If を以下のように変更 If myR Is Nothing Then   addR_No = Sh2.Range("A65536").End(xlUp).Row + 1   .Range("A" & i & ":D" & i).Copy _   Destination:=Sh2.Range("A" & addR_No & ":D" & addR_No) End If >あと、チェックデータのあたまに >コード 商品  店名  納入日  >という言葉を入れたいのですが、どのように書き込むのでしょうか? 始めにコード 商品  店名  納入日を入力しておけば、特にプログラムで設定する必要は無いと思いますが、あえてやるなら Set Sh3 = Worksheets("最新データ") の直後の行に If Sh3.Range("A1").Value <> "コード" Then   Sh3.Rows(1).Insert   Sh3.Range("A1").Value = "コード"   Sh3.Range("B1").Value = "商品"   Sh3.Range("C1").Value = "店名"   Sh3.Range("D1").Value = "納入日" End If あと余計なお世話でしょうが、元データと最新データの比較という場合、最新データが元データにあるかチェックするのが普通だと思いますが、今のマクロでは元データが最新データに存在するかどうかのチェックになっていますが、これが実現したいことなのでしょうか?

yuk777
質問者

お礼

なるほど!Notをとることで普通にIf文になるからすすめれるわけですね。 通常元データを中心にして考えるんでしょうが、今回は毎月最新データを中心にして考えて元データを作るというにしてます。 実際のデータは大量にあるので、大分進んできて楽しくなってきました。また細かい所で質問させていただきますのでよろしくお願いします。

全文を見る
すると、全ての回答が全文表示されます。

その他の回答 (1)

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.2

何がしたいか2つのケースが考えられす。 (1)元データの中で売れてない(最新データにない)明細 (2)最新データにあるが、元データにない明細 例えば、マスタになくて、販売データにある明細 (1)らしいのですが曖昧。 下記は(1)でやって見ました。 Sub test01() Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh3 As Worksheet Dim myR As Range Dim N_D As Long Dim i As Long '--------- Set Sh1 = Worksheets("元データ") Set Sh2 = Worksheets("チェックデータ") Set Sh3 = Worksheets("最新データ") '---------チェックデータ・シートに項目見だしを入れる Sh2.Cells(1, "A") = "コード" Sh2.Cells(1, "B") = "商品" Sh2.Cells(1, "C") = "店名" Sh2.Cells(1, "D") = "納入日" '-----初期値設定 j = 2 'チェックデータ・シートに第2行目から '---------元データの各行に付いて繰り返し For i = 2 To Sh1.Range("A65536").End(xlUp).Row N_D = Sh1.Range("A" & i).Value Set myR = Sh3.Range("A:A").Find(What:=N_D, LookIn:=xlValues, _ MatchCase:=False) If myR Is Nothing Then '-----見つからなかった場合 Sh2.Cells(j, "A") = Sh1.Cells(i, "A") Sh2.Cells(j, "B") = Sh1.Cells(i, "B") Sh2.Cells(j, "C") = Sh1.Cells(i, "C") Sh2.Cells(j, "D") = Sh1.Cells(i, "D") j = j + 1 '次に書く行をポイント Else '見つかった場合何もしない End If Next End Sub 質問のコードに誤り?の箇所があるようで、修正しました。出来るだけ原型を尊重しましたが、私の好みのスタイルになっている箇所があります。 (データ例)元データA1:D9 コード 商品 店名 納入日 1 みかん A店 1月3日 360 メロン D店 312 かき P店 313 キウイ D店 333 くり C店 344 リンゴ F店 322 バナナ D店 318 もも A店 最新データA1:D7 コード 商品 店名 納入日 1 みかん A店 1月3日 311 いちご B店 10月3日 250 313 キウイ F店 360 メロン G店 344 リンゴ C店 (結果)チェックデータA1:D5 コード 商品 店名 納入日 312 かき P店 333 くり C店 322 バナナ D店 318 もも A店

yuk777
質問者

お礼

とっても参考になりました。 結局のところ(1)も(2)も両方やりたかったりします。色々なシートに書き写すので。。 でも、とりあえず一つのことを教えてもらえば、あとは自分で考えようと思ってこのような曖昧な質問になってしまい、申し訳ありません。 大分進んできて楽しくなってきています。 また細かい質問いれますのでよろしくお願いします。

全文を見る
すると、全ての回答が全文表示されます。

関連するQ&A

  • ExcelVBAでデータ不一致のものの抽出

    Sheet1「元データ」                  A   B    C   D     1  0001 みかん  A店  3/1  2 0200  りんご B店  3 0311 いちご B店  3/10 4    いちじく C店 5 0360 メロン  D店 6 かき   P店 7  0312 キウイ  D店 99 0333 くり C店 Sheet2「最新データ」   A   B    C   D 1  0001 みかん  A店  3/1 2 0190 3 0200  4 0311 いちご B店  3/10 5 0422  洋ナシ C店 6 0250 7 0500 すいか  P店  8  0312 キウイ       とあった時に最新データのA列の番号と元データの番号を見て同じ物があったら、最新データに元データの内容をうつし込むというデータがあります。 Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh3 As Worksheet Dim myR As Range Dim N_D As Long Dim i As Long Set Sh1 = Worksheets("元データ") Set Sh2 = Worksheets("新規データ") Set Sh3 = Worksheets("最新データ") With Sh3 For i = 5 To .Range("A65536").End(xlUp).Row N_D = .Range("E" & i).Value Set myR = Sh1.Range("A:A").Find(What:=N_D, LookIn:=xlValues, _ MatchCase:=False) If Not myR Is Nothing Then myR.Offset(, 2).Resize(, 3).Copy _ Destination:=.Range("B" & i & ":D" & i) End If Next End With Set Sh1 = Nothing Set Sh2= Nothing Set Sh3 = Nothing ここで、もし、最新データA列の番号と元データの番号を見て一致しないもの、元データにしかないものや最新データにしかないものがあったら、新規データとして、別シートに行ごと書き写したい場合はどのようにすれば良いのでしょうか?

  • ExcelVBAマクロでのデータの受け渡し

    Sheet1「元データ」                  A   B    C   D     1  0001 みかん  A店  3/1  2 0200  りんご B店  3 0311 いちご B店  3/10 4    いちじく C店 5 0360 メロン  D店 6 かき   P店 7  0312 キウイ  D店 Sheet2「最新データ」   A   B    C   D 1  0001 みかん  A店  3/1 2 0190 3 0200  4 0311 いちご B店  3/10 5 0422  洋ナシ C店 6 0250 7 0500 すいか  P店  8  0312 キウイ       とあった時に最新データのA列の番号と元データの番号を見て同じ物があったら、最新データに元データの内容をうつし込むというデータがあります。 Dim Sh1 As Worksheet Dim Sh3 As Worksheet Dim myR As Range Dim N_D As Long Dim i As Long Set Sh1 = Worksheets("元データ") Set Sh3 = Worksheets("最新データ") With Sh3 For i = 5 To .Range("A65536").End(xlUp).Row N_D = .Range("E" & i).Value Set myR = Sh1.Range("A:A").Find(What:=N_D, LookIn:=xlValues, _ MatchCase:=False) If Not myR Is Nothing Then .Range("B" & i & ":D" & i).Value = _ myR.Offset(, 2).Resize(, 3).Value End If Next End With Set Sh1 = Nothing Set Sh3 = Nothing ここで、値は普通にコピーされてくるのですが、 フォントに色がついていたら、その色もつけたいのですが、どうすれば良いのか分らず困っています。 方法がありましたら、教えてください。 よろしくお願いします。

  • このマクロの意味を教えてください。

    このマクロの意味を教えてください。 このマクロの意味を教えてくれませんか?変な質問で申し訳ありません。というのも、先日インターネットからひろってそのままま真似して使っていたのですが、不具合が起こってしまいました。 しかし、どこからひろったのかどう検索しても見つからず、自分で不具合の原因がわからないのです。 どなたか、教えていただけないでしょうか。 このひとつひとつのマクロの意味を教えていただけたら大変助かります。 Sub test01() Dim sh1 As Worksheet Dim sh2 As Worksheet Set sh1 = Worksheets("元データ") Set sh2 = Worksheets("RMA") '-- d = sh1.Range("a65536").End(xlUp).Row For i = 2 To d If sh1.Cells(i - 1, "E") <> "" Then sh2.Cells(1, "A") = i - 1 sh2.Range("A2:I51").PrintOut End If Next i End Sub

  • エクセルVBA抽出がうまく出来ません

    エクセル2013VBA初心者です。 入力シートからDBシートへ、DBシートから印刷シートへのデータ転記と印刷、入力内容のクリアまでは出来るようになりました。 DBシートの検索を行い、記録内容を入力シートに転記する抽出を行いたいのですが、下記構文を書いたところで問題が発生しました。 If Sh2.Range("A & i").Value = j And Sh2.Range("B & i").Value = k Then  でとまります。メッセージは ‘Range’メソッドは失敗しました:‘Workshieet’オブジェクトというものです。 やろうとしていることは、入力シートに設けた“E12”と”G12”の二つの検索項目をキーにDBシートの行を特定し、この行の内容を入力シートに反映しようということです。 入力シートの検索項目“E12”、 ”G12”はそれぞれDBシートのA列、B列に格納されている項目で、年度と連番です。サンプルとして入力シート"C5"に抽出しようとしているDBシートD列は申請者名です。 恐れ入りますがよろしくご教示頂きたく、お願い申し上げます。 Sub DBシートから力情報を抽出する () Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim i As Long Dim j As Long Dim k As Long Set Sh1 = Worksheets("入力") Set Sh2 = Worksheets("DB") j = Sh1.Range("E12").Value k = Sh1.Range("G12").Value With Sh2 For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row If Sh2.Range("A & i").Value = j And Sh2.Range("B & i").Value = k Then Sh1.Range("C5").Value = Sh2.Range("D & i").Value End If Next  End With End Sub

  • ロートルの初心者です、VBAについての質問です。

    エクセル2003で以下のVBAを色々な資料を基に、「テスト2」のシートに条件検索されたデータ、マクロ起動(?)で「入力履歴」に追記されるものを作成しました。 Sub prog() Dim myFld As String, myCri As String Dim myRow As Long Dim Sh2 As Worksheet, Sh3 As Worksheet Set Sh2 = Worksheets("テスト2") Set Sh3 = Worksheets("入力履歴") With Sh2 myRow = .Range("D" & Rows.Count).End(xlUp).Row Range("A1:H" & myRow).Copy Destination:=Sh3.Range("A" & Rows.Count).End(xlUp).Offset(1) End With Sh3.Activate Range("A1").Select End Sub ここで問題となるのが抽出データには関数が含まれているため「入力履歴」シートに書き込まれたデータにもそのまま貼り付けられるので「#A/N」となってしまいます。 Range("A1:H" & myRow).Copy Destination:=Sh3.Range("A" & Rows.Count).End(xlUp).Offset(1)の 「Destination」を変えれば良いかと思ったのですが・・・、うまくいきません。 エクセルでいう、「形式を選択して貼り付け→値」をやりたいのですが書き方がわかりません。 ロートルの初心者によろしく愛の手をお願い申します。 PS:説明文があると助かります。

  • Excel VBA元データから別シートへ振り分け

    元データ(DB)をA列の値で振り分け 別シート(印刷)に転記していく方法について教えてください。 以下のコードで転記は行えましたが1つの値で1つのシートを作成になってしまいます。 どこをどのように変更すればA列の値(一種類に1つのシートにまとめたい)に 1つのシートに転記となるかご教示お願いします。 Sub test01() Dim sh1 As Worksheet Dim sh2 As Worksheet Set sh1 = Worksheets("DB") Set sh2 = Worksheets("印刷") d = sh1.Range("A65536").End(xlUp).Row For i = 2 To d sh2.Cells(6, "B") = sh1.Cells(i, "A") sh2.Cells(10, "B") = sh1.Cells(i, "B") sh2.Cells(10, "C") = sh1.Cells(i, "C") sh2.Cells(10, "D") = sh1.Cells(i, "D") sh2.Cells(10, "E") = sh1.Cells(i, "E") sh2.Cells(10, "F") = sh1.Cells(i, "F") sh2.Cells(10, "G") = sh1.Cells(i, "G") sh2.Cells(10, "H") = sh1.Cells(i, "H") sh2.Cells(10, "J") = sh1.Cells(i, "I") 'sh2.Range("a1:J34").PrintOut Next i End Sub よろしくお願いいたします。

  • エクセルVBAで実行時エラー 91 が出ます

    エクセル2000です 各部署の棚卸を纏める為のVBAを作成しているのですが、実行時にエラーになってしまいます エラーメッセージは 「実行時エラー 91   オブジェクト変数またはWithブロック変数が設定されていません」 です ご教授お願いいたします Sub 棚卸() Dim sh1 As Worksheet Dim sh2 As Worksheet Set sh1 = Worksheets("在庫集計票") Set sh2 = Worksheets("棚卸表") x = sh2.Range("A65536").End(xlUp).Row Z = sh1.Range("d2").Value ’部署番号 sh1.Range(Cells(5, Z), Cells(3000, Z)).ClearContents For i = 2 To x y = sh1.Range("A2:A" & Range("A2").End(xlDown).Row). _ Find(sh2.Cells(i, "a")).Row ’ここでエラーが発生します sh1.Cells(y, Z) = sh2.Cells(i, "c") Next i End Sub

  • どなたかマクロ修正お願いします。

    自分なりに 作成してみましたがどうもうまくいきません。 Sub 変換() Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet, Dim r As Range Set Sh1 = Worksheets("1") Set Sh2 = Worksheets("2") Set Sh3 = Worksheets("3") Sh3.Select Set c = Cells.Find(What:="9876543", LookAt:=xlWhole) c.Offset(, 1).Activate ActiveCell.Replace What:="中田", Replacement:="中田英寿" End Sub このように作成しましたがうまくいきません。恐らくsheet3のデータはsheet1から( =1!A100 )といったように値を他のsheetから持ってきてるからではないんでしょうか?

  • 行すべての値を張り付けるようにするには

    次の突合用マクロですが、照合番号だけでなく行すべてのデータを張り付けたいのですが、どの部分に変更を加えればよいかわかりません。 (添付画像をご覧ください) ・Sheet3~6にも列B~以降のデータを張り付けたい EntireRow Copy を使おうとしたのですが、どの様に行を指定すればよいかわかりませんでした。 ご教示頂ければ幸いです。 【準備して頂いたマクロ】 Sub TestX() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim Sh3 As Worksheet, Sh4 As Worksheet Dim Sh5 As Worksheet, Sh6 As Worksheet Dim Sh1data As Variant, Sh2data As Variant Dim Sh3data As Variant, Sh4data As Variant Dim Sh5data As Variant, Sh6data As Variant Dim Sh1LastRow As Long, Sh2LastRow As Long Dim i As Long, j As Long, Sh5flg As Boolean Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") Set Sh3 = Worksheets("Sheet3") Set Sh4 = Worksheets("Sheet4") Set Sh5 = Worksheets("Sheet5") Set Sh6 = Worksheets("Sheet6") ReDim Sh3data(0) ReDim Sh4data(0) ReDim Sh5data(0) ReDim Sh6data(0) Sh1LastRow = Sh1.Cells(Rows.Count, "A").End(xlUp).Row Sh2LastRow = Sh2.Cells(Rows.Count, "A").End(xlUp).Row Sh1data = Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Sh1LastRow, "B")).Value Sh2data = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Sh2LastRow, "B")).Value For i = 1 To Sh1LastRow - 2 Sh5flg = False For j = 1 To Sh2LastRow - 2 If Sh1data(i, 1) = Sh2data(j, 1) Then If Sh2data(j, 2) <> "◯" Then Sh1data(i, 2) = "◯" Sh3data(UBound(Sh3data)) = Sh1data(i, 1) ReDim Preserve Sh3data(UBound(Sh3data) + 1) Sh2data(j, 2) = "◯" Else Sh5data(UBound(Sh5data)) = Sh1data(i, 1) ReDim Preserve Sh5data(UBound(Sh5data) + 1) Sh5flg = True End If Exit For End If Next j If Sh1data(i, 2) <> "◯" And Sh5flg = False Then Sh5data(UBound(Sh5data)) = Sh1data(i, 1) ReDim Preserve Sh5data(UBound(Sh5data) + 1) End If Next i For i = 1 To Sh2LastRow - 2 If Sh2data(i, 2) = "◯" Then Sh4data(UBound(Sh4data)) = Sh2data(i, 1) ReDim Preserve Sh4data(UBound(Sh4data) + 1) Else Sh6data(UBound(Sh6data)) = Sh2data(i, 1) ReDim Preserve Sh6data(UBound(Sh6data) + 1) End If Next Sh1.Range("A3").Resize(Sh1LastRow - 2, 2).Value = Sh1data Sh2.Range("A3").Resize(Sh2LastRow - 2, 2).Value = Sh2data Sh3.Range("A3").Resize(UBound(Sh3data), 1).Value = WorksheetFunction.Transpose(Sh3data) Sh4.Range("A3").Resize(UBound(Sh4data), 1).Value = WorksheetFunction.Transpose(Sh4data) Sh5.Range("A3").Resize(UBound(Sh5data), 1).Value = WorksheetFunction.Transpose(Sh5data) Sh6.Range("A3").Resize(UBound(Sh6data), 1).Value = WorksheetFunction.Transpose(Sh6data) Set Sh1 = Nothing Set Sh2 = Nothing Set Sh3 = Nothing Set Sh4 = Nothing Set Sh5 = Nothing Set Sh6 = Nothing End Sub

  • 式を残して値のみ削除

    Sub clear() Dim wskyu As Worksheet Dim wsData As Worksheet Dim Y As Range Const SH_KYUYO As String = "給与明細" Const SH_DATA As String = "データ入力" Set wskyu = Worksheets(SH_KYUYO) Set wsData = Worksheets(SH_DATA) With wsData For Each Y In .Range("C3:G55") If Y.Interior.ColorIndex <> xlNone Then Y.ClearContents End If Next End With With wskyu Range ("P7:AQ7"), .Range("D10:AQ10"), .Range("D13:AQ13"), _ .Range("D17:AQ17"), .Range("D20:AQ20"), .Range("D24:AQ24"), _ .Range("D29:AI29").Select Selection.SpecialCells(xlCellTypeConstants, 23).Select Selection.ClearContents End With MsgBox "個人番号を入力後、性別を選択しボタン(1)を押してください" End Sub 値のみ削除しようと上のコードを書いたのですが With wskyu のあとの Range~ でプロパティの使い方が不正です と言われてしまいました(-_-;) ヘルプボタンがあったので押しても空のページに飛んでしまい どうすればよいのかわかりません、、、 どうかよろしくおねがいします!!

このQ&Aのポイント
  • 服やズボンを何回も洗うとヨレヨレになったり、傷むことがあります。その原因は、洗濯の段階にあります。洗濯機で洗濯する際の最初の水に浸る段階や次の洗われる段階、すすぎの段階、脱水の段階のどこかで繰り返し洗濯することが原因です。
  • 洗濯で服やズボンがヨレヨレになる原因は、洗濯の段階にあります。洗濯機で洗濯する際の最初の水に浸る段階や洗われる段階、すすぎの段階、脱水の段階のいずれかで繰り返し洗濯することが原因です。
  • 服やズボンを何回も洗うとヨレヨレになったり、傷むことがあります。この原因は、洗濯の段階にあります。洗濯機で洗濯する際の最初の水に浸る段階や洗われる段階、すすぎの段階、脱水の段階のどれかで繰り返し洗濯することが原因です。
回答を見る

専門家に質問してみよう