エクセルVBAで別シートから値を検索して挿入する方法

このQ&Aのポイント
  • VBAを使用して、エクセルのSheet1の指定の列にSheet2から値を検索して挿入する方法について説明します。
  • Sheet1の指定の列には既に値が入っていますが、本コードを実行すると検索にヒットしない商品の値はエラーとなります。
  • 改良方法について教示いただければ助かります。
回答を見る
  • ベストアンサー

エクセル 別シートから値を検索して挿入 VBA

いつもお世話になっております。 VBAにて、Sheet1 の【原価】に【商品】をキーにしてSheet2の【原価】を検索して挿入するコードを作成しました。 元々Shee1の【原価】にはすでに数値が入っていますが、下記のコードを実行すると上書きする処理のため、検索にヒットしない商品の【原価】はエラー【#N/A】となります。 ※画像参照願います。 目的はヒットする商品名の【原価】のみが更新される、 ヒットしない場合エラー【#N/A】を出さないようにする。 改良をご教示頂ければ助かります。 Sub データ検索() Application.ScreenUpdating = False Dim I As Long   I = 2 Do While Range("A" & I).Value <> ""  ThisWorkbook.Worksheets("Sheet1").Range("C" & I).Value = _   Application.VLookup(ThisWorkbook.Worksheets("Sheet1").Range("B" & I).Value, Worksheets ("Sheet2").Range("A2:B65535"), 2, 0)  I = I + 1 Loop Application.ScreenUpdating = True End Sub

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

  • ベストアンサー
  • dogs_cats
  • ベストアンサー率38% (278/717)
回答No.5

sheet1に既に単価が入力されてるなら空白を入力しないようにするだけでしょう。その修正も出来ませんか? Sub データ検索() Dim I As Long Dim ws As Worksheet Application.ScreenUpdating = False Set ws = Sheets("sheet2") With Sheets("sheet1") I = 2 Do While .Range("A" & I).Value <> "" If Application.CountIf(ws.Range("A:A"), .Range("B" & I)) = 1 Then .Range("C" & I).Value = _ Application.VLookup(.Range("B" & I).Value, ws.Range("A:B"), 2, 0) End If I = I + 1 Loop End With Application.ScreenUpdating = True End Sub

nezumisansan
質問者

お礼

dogs_cats さん、ありがとうございます。コード内容が一番シンプルで解読しやすいため、ベストアンサーとさせて頂きました。おっしゃる通り勉強致します。ほかの方もご回答ありがとうございました。

その他の回答 (4)

  • kagakusuki
  • ベストアンサー率51% (2610/5101)
回答No.4

 こういう方法もあります。 Sub Macro1() Const mySheetName1 = "Sheet1" Const FirstRow1 = 2 Const CommodityColumn1 = 2 Const CostColumn1 = 3 Const mySheetName2 = "Sheet2" Const FirstRow2 = 3 Const CommodityColumn2 = 1 Const CostColumn2 = 2 Dim mySheetName(1) As String, mySheet(1) As Worksheet _ , LastRow As Long, i As Long, c As Range mySheetName(0) = "Sheet1" mySheetName(1) = "Sheet2" For i = 0 To 1 Set mySheet(i) = Sheets(mySheetName(i)) Next i With mySheet(0) LastRow = .Cells(Rows.Count, CostColumn1).End(xlUp).Row If LastRow < FirstRow1 Then Exit Sub Application.ScreenUpdating = False Application.Calculation = xlManual With Range(.Cells(FirstRow1, CostColumn1), .Cells(LastRow, CostColumn1)) For Each c In .Offset(0) c.FormulaR1C1 = "=IF(RC" & CommodityColumn1 & "="""","""",IF(COUNTIF(" _ & mySheetName(1) & "!C" & CommodityColumn2 & ",RC" & CommodityColumn1 _ & "),VLOOKUP(RC" & CommodityColumn1 & "," & mySheetName(1) & "!C" _ & CommodityColumn2 & ":C" & CostColumn2 _ & "," & CostColumn2 - CommodityColumn2 + 1 & ",FALSE)," & c.Value & "))" Next c .Parent.Calculate .Value = .Value End With End With With Application .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub

nezumisansan
質問者

補足

kagakusuki さん、ご回答ありがとうございます。正直今のレベルでは内容が理解できません。ゆっくりですが勉強して解読したいと思います。 ありがとうございました。

  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.3

ん? >関数式は残したくありません。 >数値として残す場合はどのような処置となりますでしょうか? 回答したマクロの最後の方の3カ所の「’」を消します。 #コピーして動かしてみたー できたー ダメだったー でオワリじゃなくて,回答のマクロがナニをやってるのかご自分なりにちょっと考えてみると良いと思います。

nezumisansan
質問者

お礼

keithin さん、早速にありがとうございます。おっしゃる通り勉強不足です。勉強致します。ありがとうございました!

  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.2

アイデア次第でやりようはいくらでもあります。 作成例:セルをイチイチ巡回するのもやめ。該当データ行だけ限定で一気にVLOOKUPする sub macro1()  worksheets("Sheet1").range("B:B").advancedfilter _   action:=xlfilterinplace, _   criteriarange:=worksheets("Sheet2").range("A1:A" & worksheets("Sheet2").range("A65536").end(xlup).row), _   unique:=false  worksheets("Sheet1").range("C2:C" & worksheets("Sheet1").range("B65536").end(xlup).row).specialcells(xlcelltypevisible).formular1c1 _  = "=VLOOKUP(RC[-1],Sheet2!C1:C2,2,FALSE)"  worksheets("Sheet1").showalldata ’with worksheets("Sheet1").range("C2:C" & worksheets("Sheet1").range("B65536").end(xlup).row) ’ .value = .value ’end with end sub

nezumisansan
質問者

補足

keithin さん、早速にご回答ありがとうございます。 おおむね、ご回答頂きました処置で目的は達成しておりますが 関数式は残したくありません。 数値として残す場合はどのような処置となりますでしょうか? お手数ですがよろしくお願い致します。

  • dogs_cats
  • ベストアンサー率38% (278/717)
回答No.1

countif関数で商品名の有無を検索すれば良いのでは。 本コードでは他のBOOKをオープンさせていないのでthisworkbookは不要と判断しました。 商品名が存在しない場合は空白を単価に入力する事にしています。 Sub データ検索() Dim I As Long Dim ws As Worksheet Application.ScreenUpdating = False Set ws = Sheets("sheet2") With Sheets("sheet1") I = 2 Do While .Range("A" & I).Value <> "" If Application.CountIf(ws.Range("A:A"), .Range("B" & I)) = 1 Then .Range("C" & I).Value = _ Application.VLookup(.Range("B" & I).Value, ws.Range("A:B"), 2, 0) Else .Range("C" & I).Value = "" End If I = I + 1 Loop End With Application.ScreenUpdating = True End Sub sheet2をwsというオブジェクト変数に格納して、コードを短くしています。 http://officetanaka.net/excel/vba/variable/04.htm withステートメントでsheet1を指定しています。 sheet1に関するrangeの前にピリオドを付ける必要があります。 withステートメントの説明 http://officetanaka.net/excel/vba/beginner/16.htm

nezumisansan
質問者

補足

dogs_cats さん、早速にご回答・参考ありがとうございます。 ↓↓ 商品名が存在しない場合は空白を単価に入力する事にしています。 ご説明不足で申し訳ございません。 元々Sheet1の商品にすべて原価が入っており、 VBAを実行すると該当の商品名だけが更新され、空白およびエラー【#N/A】にならないように処理し、 かつ、該当しない商品名の原価はそのままの数値を残したいと考えております。お手数ですがその場合はどのような処理となりますでしょうか?

関連するQ&A

  • エクセル 何故かシート間の値のコピーが出来ない

    いつもお世話になります。 開いているブックのシート「リスト1~3」に、Book1.xlsの「リスト1~3」の値をコピーする為に、下記のマクロを作成しました。 Dim SH1, SH2, SH3, SH4, SH5, SH6 As Worksheet Set SH1 = ThisWorkbook.Worksheets("リスト1") Set SH2 = ThisWorkbook.Worksheets("リスト2") Set SH3 = ThisWorkbook.Worksheets("リスト3") Set SH4 = Workbooks("Book1.xls").Worksheets("リスト1") Set SH5 = Workbooks("Book1.xls").Worksheets("リスト2") Set SH6 = Workbooks("Book1.xls").Worksheets("リスト3") 'リスト1をコピーする D = SH4.Range("A1").CurrentRegion.Rows.Count E = SH4.Range("A1").CurrentRegion.Columns.Count SH1.Range(Cells(1, 1), Cells(D, E)).Value = SH4.Range("A1").CurrentRegion.Value 'リスト2をコピーする F = SH5.Range("A1").CurrentRegion.Rows.Count G = SH5.Range("A1").CurrentRegion.Columns.Count SH2.Range(Cells(1, 1), Cells(F, G)).Value = SH5.Range("A1").CurrentRegion.Value 'リスト3をコピーする H = SH6.Range("A1").CurrentRegion.Rows.Count I = SH6.Range("A1").CurrentRegion.Columns.Count SH3.Range(Cells(1, 1), Cells(H, I)).Value = SH6.Range("A1").CurrentRegion.Value 以上を実行すると、「アプリケーション定義またはオブジェクト定義のエラーです」とエラーメッセージが出てしまいます。 それぞれのシートの処理の時に、 SH1.Select SH2.Select SH3.Select を入れて、シートを選択してから実行すると問題なく動くのですが、何故このようなことが起こるのでしょう?

  • Excel VBAで検索をするには

    他シートのセル位置を指定して、その言葉をキーワードに 検索をかけて、該当列の列数を取得しようと思っております。 他シートのセル位置の指定の仕方がわかりません。。 言葉指定の検索は下記の通りできました。 Dim i As Integer Application.ScreenUpdating = False '2行目で検索 i = Range("IV2").End(xlToLeft).Column To 1 Step -1 If InStr(Cells(2, i).Value, "$金額$") > 0 Then '列数取得  ・   ・ End If Application.ScreenUpdating = True ここまで。 $金額$の場所に、他シートのRange("A1")を指定する方法を 教えて下さい!!

  • エクセルVBAで別シートへ情報を加工して移したい

    すみません、本当に困ってます。 皆様お忙しいとは存じますが、何卒お力添え頂けませんでしょうか。 エクセルVBAは完全に素人です。 AのシートからBのシートへ欲しい情報だけを抜き出して 一覧表にしていきたいのですが、できないでいます。 いろいろ調べながら現在、AのシートからBのシートへ 情報を移動させ、最後にAのシートをクリアするとこまでできたのですが、 そこから行き詰りました。 やり方としては、Aシートが入力シートとなっています。 Aシートには、届いたメール本文をテキストでそのままペーストします。 そうしますと、AシートのA列には、 ***************** ご利用ID   :99 営業形態   :店舗 事業所名   :サンプル所 ***************** という文字列が入ります。 このAシートに入った情報をBシートのA列に ***************** 99 店舗 サンプル所 ***************** という形に加工して貼り付けたいです。 一応、以下のようにやっているのですが、どうしたら良いか 分かりません。 Private Sub CommandButton1_Click() 'コピー用の項目を作成 '一覧に追加して下へ Worksheets("Bシート").Range("1:1").Insert shift:=xlShiftDown 'IDを追加 Worksheets("Bシート").Range("A1").Value = Application.Transpose(Worksheets("Aシート").Range("A1")) '営業形態を追加 Worksheets("Bシート").Range("A2").Value = Application.Transpose(Worksheets("Aシート").Range("A2")) 申し訳ございませんが、お力添え頂けませんでしょうか。 何卒宜しくお願い申し上げます。

  • VBAのエラーについて

    いつも識者の皆様にはお世話になっております。 Excel VBAのことで質問させてください。 Range("i23").Value = Application.VLookup(ThisWorkbook.Worksheets("aaa").Range("b5"), ThisWorkbook.Worksheets("data").Range("a2:b7"), 2, 0) というコードは通るのですが、 Range("i23").Value = Application.Left(VLookup(ThisWorkbook.Worksheets("aaa").Range("b5"), ThisWorkbook.Worksheets("data").Range("a2:b7"), 2, 0), 2) というleft関数を追加したコードだと「sub または function が定義されていません」というエラーになってしまいます。 VBAを始めたばかりなのですが、何か根本的な勘違いをしていますでしょうか? ちなみに Range("i23").Value = Application.Left(Application.VLookup(ThisWorkbook.Worksheets("aaa").Range("b5"), ThisWorkbook.Worksheets("data").Range("a2:b7"), 2, 0), 2) というコードも通りませんでした。 ご回答よろしくお願いいたします。

  • 【VBA】 超初心者です 複数のシートに転記したい

    Sub べんきょう() Worksheets(Array(1, 3)).Select Range("A1").value = 20 End Sub もしくは Sub べんきょう() Worksheets("sheet1").Select Worksheets("sheet3").Select False Range("A1").value = 20 End Sub でやってもsheet1にしか転記されないんです!! ご指導よろしくお願いします!

  • Excel VBAでの質問

    以前、質問に回答頂きそれを実行してうまくいったのですが、 特定のsheetだけsheetのつくりが違うため、 このsheetは毎回なにも処理をしないという処理を加えたいのですが、 (例えばsheet5とsheet8は処理をしない) 下記のコードにどのように付け加えればよいでしょうか? わかるかた宜しくお願い致します。 Dim i As Long For i = 1 To Worksheets.Count  If Worksheets(i).Range("A1").Value = 10 Then Worksheets(i).Range("K1") = Worksheets(i).Range("A1")  Worksheets(i).Range("A1:D80").ClearContents Next End Sub

  • VBA中の”シート名”を”アクティブシート”に変更

    いつもお世話になっております。 非常に初歩的な質問なのですが、下記の2つのVBA中のシート名をアクティブシートに変更したいのですが、 sheetName = ActiveSheet.Name で試行錯誤するもうまくいきません。 実際のコードは下記の通りです。 これらのシート名”申請書”をアクティブシートに変更したいのです。 このコードは過去にここで教えて頂いたコードで出来ればこれを修正したいので宜しくお願いします。 1.Sub 申請書登録() Dim NewBookName As String With ThisWorkbook.Sheets("申請書") Windows("1.新規・変更登録申請書(原紙)・リスト②T用.xlsm").Activate For i = 5 To Sheets("規格登録・変更リスト").Range("A1048576").End(xlUp).Row + 1 If Sheets("規格登録・変更リスト").Range("B" & i).Value = "" Then With Sheets("規格登録・変更リスト") .Range("A" & i).Value = Sheets("申請書").Range("E3").Value .Range("B" & i).Value = Sheets("申請書").Range("O3").Value .Range("C" & i).Value = Sheets("申請書").Range("E4").Value ・・・・・・・・・・・・・・・・・・・ 2.Sub 申請書保存() Dim NewBookName As String With ThisWorkbook.Sheets("申請書") NewBookName = .Range("F22").Value & " " & .Range("E4").Value & " " & .Range("A2").Value & " " & .Range("A1").Value Worksheets("申請書").ExportAsFixedFormat Type:=xlTypePDF, Filename:="\***\XXXX\1.申請書\申請書" & "\" & NewBookName End With End Sub

  • エクセルで置換リストを別ブックにおいたマクロを作りたい

    置換専用につくったワークシートに A列に検索文字 B列に置換文字を入力したリスト(例えば"Book2.xls"の"sheet1")を作りました。 このリストを使って別のブック内(例えば"Book1.xls")の複数のシート内を一括して置換えがしたいです。 自分で調べてみて下記で置換えはできたのですが、その都度、各シートを選択しなければだめでした。 一括で同ブック内の複数シート内を置換えさせるには、どこを修正したらいいのでしょうか? 見よう見まねの初心者です。 どうぞよろしくお願いします。 Sub 置換()  With ThisWorkbook   If ActiveSheet Is .Worksheets(1) Then Exit Sub   For i = 1 To .Worksheets(1).Range("A65536").End(xlUp).Row    ActiveSheet.Cells.Replace _      What:=.Worksheets(1).Range("A" & i).Value, _      Replacement:=.Worksheets(1).Range("B" & i).Value, _      LookAt:=xlPart, SearchOrder:=xlByColumns   Next  End With End Sub

  • EXCELのシートを並べ替えすると・・・

    エクセルのシートを並べ替えようと思って こちらで調べてようやく並べ替えができるようになったのですが、幾つかあるデータの中で実行するとエラーが出るものがあります。 シートの名前は1日~31日&集計という構成なのですが、下記を実行すると実行エラー9:インデックスが有効範囲にありません!とでます…デバックを押すと Worksheets(CStr(Wwh.Cells(N, 1).Value)).Move After:=Sheets(N) のところが黄色になっています。 同じようなシートの構成があるデータで試してみると成功するものと失敗するものがありもう何がなにやら(;´Д`) 何か変更しないとだめなんでしょうか? 分かる人がいたらアドバイスお願いします。 Sub SortSheets() Dim Wwh As Worksheet Dim N As Integer Application.ScreenUpdating = False Sheets.Add Before:=Worksheets(1) Set Wwh = ActiveSheet For N = 2 To Worksheets.Count   Cells(N - 1, 1).Value = Worksheets(N).Name   Cells(N - 1, 2).Value = _   Application.GetPhonetic(Worksheets(N).Name) Next N Range("A1").CurrentRegion.Sort Key1:=Range("B1"), _   Order1:=xlAscending, Header:=xlNo, OrderCustom:=1 '昇順 'Range("A1").CurrentRegion.Sort Key1:=Range("B1"), _   Order1:=xlDescending, Header:=xlNo, OrderCustom:=1 '降順 For N = 1 To Range("A1").End(xlDown).Row   Worksheets(CStr(Wwh.Cells(N, 1).Value)).Move After:=Sheets(N) Next N For N = 2 To Worksheets.Count   If Worksheets(N).Visible = xlSheetVisible Then     Worksheets(N).Activate     Exit For   End If Next N Application.DisplayAlerts = False Wwh.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True Set Wwh = Nothing End Sub

  • Setステートメントをまとめて記述する方法 (エクセル2000VBA)

    お世話になります。 Setステートメントで以下のように書いて、シート名を省略して使っています。  Set a = ThisWorkbook.Worksheets("い")  Set b = ThisWorkbook.Worksheets("ろ")  Set c = ThisWorkbook.Worksheets("は") これをプロシージャ毎に書くとコードが長くなるので、先頭かどこかに1回書くだけで、全てのプロシージャで使えるようにしたいのですがどうしたら良いでしょうか? このようなプロシージャを実行したいのですが、 Private Sub CommandButton1_Click()  a.Range("A2").Value = "データ1"  b.Range("B4").Value = "データ2"  c.Range("C9").Value = "データ3" End Sub (他にもコマンドボタンやチェックボックス用のプロシージャがあります) Setステートメントだけを先頭に書くと、 「プロシージャの外では無効です」というエラーが出ましたので、 Public Sub hensuu()  Set a = ThisWorkbook.Worksheets("い")  Set b = ThisWorkbook.Worksheets("ろ")  Set c = ThisWorkbook.Worksheets("は") End Sub のようにしたら、「実行時エラー"424":オブジェクトが必要です」というエラーが出てしまいました。 どのようにしたらエラーが出ず正しく動くようになりますでしょうか?よろしくお願いします。

専門家に質問してみよう