• 締切済み

VBAでVLOOKUP関数を使う

「在庫検索」に下記条件を追加するには、どうすれば良いのでしょうか。 1)G列が1500より大きければ Results = Application.WorksheetFunction.VLookup(ItemCode, SerchArea, 2, False) 2)G列が1500より小さければ Results = Application.WorksheetFunction.VLookup(ItemCode, SerchArea, 3, False) どちらの際も空白の条件、If ActiveCell.offset(i, 1).value = ""は残ります。 1)、2)とandを組み合わせる方法でチャレンジしたのですが、出来ませんでした。 ------------------------------------------------------------------------ 以下がベースの「在庫検索」です。 一度、質問して解決したのですが、更なる問題が発生してしまいました。 ご指導ください。 ------------------------------------------------------------------------ Sub 在庫数検索() Dim SerchName As String Dim SerchArea As Range Dim Results As Variant '初期設定 Range("A2").Activate ItemCode = Range("A2").Value i = 0 '検索範囲の設定(ポイント1) Set SerchArea =Worksheets("シート2").Range("List1") '商品コードが空になったら終わり Do Until ItemCode = "" If ActiveCell.offset(i, 1).value = "" Then '★1 On Error Resume Next ItemCode = ActiveCell.offset(i, 0).value Results = Application.WorksheetFunction.VLookup(ItemCode, SerchArea, 2, False) If Err <> 0 Then Results = "" ActiveCell.offset(i, 1) = Results End If '★1 i = i + 1 Loop

みんなの回答

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

ヤリタイことをもうちょっと整理してみると,結局だいたい次のようになります。 sub macro1()  dim Target as range  dim i as long  set target = worksheets("シート2").range("List1")  on error resume next ’A列について巡回する  for i = 2 to range("A65536").end(xlup).row  ’B列が空なら計算する   if cells(i, "B") = "" then   ’VLOOKUPがエラーでなければ記入する    cells(i, "B") = application.worksheetfunction.vlookup(cells(i, "A").value, target, iif(cells(i, "G")>=1500, 2, 3), false)   end if  next i end sub

  • kybo
  • ベストアンサー率53% (349/647)
回答No.1

G列というのが、「ItemCode」の値なのだとしたら、以下の様にします。 Do Until ItemCode = "" If ActiveCell.Offset(i, 1).Value = "" Then '★1 On Error Resume Next ItemCode = ActiveCell.Offset(i, 0).Value If ItemCode > 1500 Then ’● Results = Application.WorksheetFunction.VLookup(ItemCode, SerchArea, 2, False)’●   Else’● Results = Application.WorksheetFunction.VLookup(ItemCode, SerchArea, 3, False)’● End If’● If Err <> 0 Then Results = "" ActiveCell.Offset(i, 1) = Results End If '★1 i = i + 1 Loop

関連するQ&A

  • VBAでVLOOKUP関数を使う

    下記VBAでResultsを反映する(更新)するのは、 空白セルだけにするのは、どうすれば良いのでしょうか。 (※参考:http://myrtus21.com/blog/2007/06/vbavlookup.html) 1日かけてトライしていますが、打開できません。 どなたかご教授願います。 どうかよろしくお願いいたします。 Sub 在庫数検索() Dim SerchName As String Dim SerchArea As Range Dim Results As Variant '初期設定 Range("A2").Activate ItemCode = Range("A2").Value i = 0 '検索範囲の設定(ポイント1) Set SerchArea =Worksheets("シート2").Range("List1") '商品コードが空になったら終わり Do Until ItemCode = "" 'エラーになっても続行する(ポイント2-1) On Error Resume Next '商品コードに該当するデータを探し、Resultsに入れる ItemCode = ActiveCell.Offset(i, 0).Value Results =Application.WorksheetFunction.VLookup(ItemCode, SerchArea, 2, False) '該当するデータがないとエラーになるための処理、エラーなら空欄にする(ポイント2-2) If Err <> 0 Then Results = "" ActiveCell.Offset(i, 1) = Results i = i + 1 Loop End Sub

  • VBAでVLOOKUPを使用

    Sheet1とListというシートがあり、 Sheet1のF4を検索の条件として、Listシートのitem_list(A2:E100)から 数値を引っ張ってくるマクロを探して、ようやく下記のコードを見つけ、 表示させる事に成功しました。 item_listの2行目が現状でF5に表示されるようになってますが、 これにプラスして、同時にitem_listの3行目をF6、4行目をF7に表示させる所で 行き詰っています。 下記のコードはネットで見つけまして、自分の設定に合わせ少し変更した 程度でまだまだ理解不足の点が多く、今回質問させて頂きました。 ご教授宜しくお願いいたします。 Private Sub Worksheet_Change(ByVal Target As Range) '変更のあったセルが Target という引数で参照できます Select Case Target.Address '入力したセルが F4 ならば Sub Find を Call します Case "$F$4" Dim SerchName As String Dim SerchArea As Range Dim Results As Variant '初期設定 Range("F4").Activate ItemCode = Range("F4").Value i = 0 '検索範囲の設定(ポイント1) Set SerchArea = Worksheets("List").Range("item_list") '商品コードが空になったら終わり Do Until ItemCode = "" 'エラーになっても続行する On Error Resume Next '商品コードに該当するデータを探し、Resultsに入れる ItemCode = ActiveCell.Offset(i, 0).Value Results = Application.WorksheetFunction.VLookup(ItemCode, SerchArea, 2, False) '該当するデータがないとエラーになるための処理、エラーなら空欄にする If Err <> 0 Then Results = "" ActiveCell.Offset(1, i) = Results i = i + 1 Loop End Select End Sub

  • VBA CHANGEイベントに複数イベントを

    いつもお世話になっています。 色々しらべて試してみたんですが、うまくいかないんで教えてください。 CHANGEイベントに複数のイベントを書き込みたいんですが。 今現在、問題なく動いている以下のイベントがあります。 (1) Private Sub Worksheet_Change(ByVal Target As Range) Dim rang3 As Range Dim rang4 As Range Dim ■■ As String Dim LastRow1 As Long LastRow1 = Worksheets("○○").Cells(Rows.Count, "b").End(xlUp).Row Set rang4 = Worksheets("○○").Range("b:I" & LastRow) Set rang3 = Range("h4") If Intersect(Target, rang3) Is Nothing Then Exit Sub On Error Resume Next ■■ = WorksheetFunction.VLookup(Target.Value, rang4, 2, 0) If Err.Number > 0 Then MsgBox Target.Value & "はありません。基本情報台帳に入力してください。" Range("h4").Select Else Application.EnableEvents = False Range("I4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 2, False) Range("j4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 3, False) Range("k4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 7, False) Range("l4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 8, False) Range("m4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 5, False) Application.EnableEvents = True Range("K4").Select End If End Sub このシートにもう一つ、イベントを入れたいのですが。 (2) If Target.Count > 1 Then Exit Sub If Intersect(Target, Range("E4")) Is Nothing Then Exit Sub Else If Range("e4").Value = "1" Then Target.Offset(0, 19).Value = "☆" End If どこに入れればいいのかわかりません。 (3) また、(2)のイベントの他に、 (1)のVLOOLUPが実行され、尚且つ(2)のイベントのE4が値が1だった場合、Y4にH4の値を入れたいのですが・・・。 (2)のみなら動くことは確認できましたが、(1)のexit sub の直前に入れたり、end ifの前に入れたりしましたが、片方は動くが、もうひとつが動かないです。 (3)については、まったくわかりません。 マクロについて、自分でネットで勉強した程度なので、基本がわかっていないからなのでしょうが・・・。 どなたか、教えてください。 お願いします。

  • エクセルVBA VLOOKUPについて

    エクセル VBA初心者です。 関数でのVLOOKUPをVBAで作りたいのですが、上手くいきません。 あらかじめ、Sheet2の1から300行までに A列  / B列 商品名 / 商品コード が入力されています。(名前の定義=商品コード) Sheet1にユーザーフォームを利用して、データを書き込んだ後、 B列に商品名が書き込まれると、 A列に商品コードが表示されるようにしたいと考えています。 A列に =IF(B2="","",VLOOKUP(B2,商品コード,2,FALSE)) と入力していたのですが、 VBAでIfを使って出来ないかと考えてみたのですが、 上手くいきませんでした。 Private Sub Worksheet_Change(ByVal Target As Range) Dim sRow As Long Dim sColumn As Long sRow = ActiveCell.Row sColumn = ActiveCell.Column If Cells(sRow, 2).Value = True Then Cells(sRow, 1).Value = WorksheetFunction.VLookup(Cells(sRow2).Value, Worksheets("Sheet2").Range("A1:B300"), 2, False) ElseIf Cells(sRow, 2).Value = " " Then Cells(sRow, 1).Value = " " End If End Sub ご教授いただけないでしょうか? エクセル2003 WindowsXP

  • VBAが止まります。

    皆さん、いつもありがとうございます。 下から14行目の『 objMail.Attachments.Add asrs1』で止まってしまします。 下から14行目の『 objMail.Attachments.Add asrs1』で止まってしまします。 asrs1をadrs1へ修正したりしましたが、改善されません。 昨日まで動いたいたのですが。 皆様、修正方法を教えていただけますでしdょうか。 ------------------------------------------------------- Sub メール作成() Dim objOutlook As Outlook.Application Dim objMail As Outlook.MailItem Dim wsMail As Worksheet Dim filead As String Dim tenp1 As String Dim tenp2 As String 'メール立ち上げ Set objOutlook = New Outlook.Application Set wsMail = ThisWorkbook.Sheets("リスト") '添付ファイルのアドレスを変数にする filead = Worksheets("リスト").Range("B3").Value '共通添付データのアドレスを読む tenp1 = filead & "\" & Worksheets("リスト").Range("B4") tenp2 = filead & "\" & Worksheets("リスト").Range("B5") Dim kobetsumail1 As String Dim kobetsumail2 As String Dim adrs1 As String Dim asrs2 As String '変数iを設定。最初は1 Dim i As Long i = 1 '送付前の確認メッセージ Dim rc As Long rc = MsgBox("記載に誤りが無いことを確認しましたか?", vbYesNo + vbQuestion, "確認") If rc = vbNo Then MsgBox "中断しました" End End If '基準となるセルを選択 Worksheets("リスト").Select Range("B7").Select '取引先名が書かれているB列が空欄になるまで続ける Do Until ActiveCell.Offset(i, 0).Value = "" '送付チェック欄が○なら作業を続ける If ActiveCell.Offset(i, 2).Value = "○" Then Set objMail = objOutlook.CreateItem(olMailTtem) '個別メールのデータ名称を読む Dim CC12(1) As String CC12(0) = ActiveCell.Offset(i, 6).Value CC12(1) = ActiveCell.Offset(i, 8).Value 'メールを作成する With wsMail objMail.to = ActiveCell.Offset(i, 4).Value objMail.CC = Join(CC12, ";") objMail.Subject = Range("B1").Value objMail.Bodyformat = olFormatPlain objMail.body = Range("B7").Offset(i, 0) & vbCrLf & Range("E7").Offset(i, 0) & "様" & vbCrLf & vbCrLf & Range("B2").Value & vbCrLf & vbCrLf kobetsumail1 = ActiveCell.Offset(i, 9).Value asrs1 = filead & "\" & kobetsumail1 kobetsumail2 = ActiveCell.Offset(i, 10).Value asrs2 = filead & "\" & kobetsumail2 If Range("B4").Value <> "" Then objMail.Attachments.Add tenp1 End If If Range("B5").Value <> "" Then objMail.Attachments.Add tenp2 End If If ActiveCell.Offset(i, 9).Value <> "" Then objMail.Attachments.Add asrs1 End If If ActiveCell.Offset(i, 10).Value <> "" Then objMail.Attachments.Add asrs2 End If objMail.Display objMail.Save End With End If i = i + 1 Loop Set objOutlook = Nothing MsgBox "下書きに保管しました" End Sub

  • VBAでVlookupを使って

    いつもお世話になっています。 VBAで現場検索登録シートと言うところに 一覧シートからVlookupを使って 表示させようと思い作りました。 エラーも何もでません。 ただ、表示されるものがちゃんと検索されるものと まったくされないものがあります。 Vlookupはマクロの記録から作ったものです。 原因がわかりません。 よろしくお願い致します。 '検索ボタン Private Sub CommandButton6_Click() '送り方 Range("C4:D4").Select ActiveCell.FormulaR1C1 = "=VLOOKUP(R2C5,一覧!R5C1:R2000C54,22,FALSE)" Selection.Value = Selection.Value '封筒 Range("C5:D5").Select ActiveCell.FormulaR1C1 = "=VLOOKUP(R2C5,一覧!R5C1:R2000C54,23,FALSE)" Selection.Value = Selection.Value '得意先名ふりがな Range("C6:F6").Select ActiveCell.FormulaR1C1 = "=VLOOKUP(R2C5,一覧!R5C1:R2000C54,6,FALSE)" Selection.Value = Selection.Value '得意先名 Range("C7:F8").Select ActiveCell.FormulaR1C1 = "=VLOOKUP(R2C5,一覧!R5C1:R2000C54,4,FALSE)" Selection.Value = Selection.Value '現場名ふりがな Range("C9:H11").Select ActiveCell.FormulaR1C1 = "=VLOOKUP(R2C5,一覧!R5C1:R2000C54,9,FALSE)" Selection.Value = Selection.Value '現場名 Range("C10:H11").Select ActiveCell.FormulaR1C1 = "=VLOOKUP(R2C5,一覧!R5C1:R2000C54,7,FALSE)" Selection.Value = Selection.Value End Sub エラーも何もなく、ちゃんと動くことは動きます。 検索結果が、検索コードによって違うのです。 よろしくお願い致します

  • excel vbaでの質問になります

    このようなマクロを作成したのですが、セルに数式が入れてあると、どうしてもその下の空白の行に値を入力されてしまいます。 数式が入っているセルにもそのままセルに値を入れたいのですが・・ 宜しくお願いします。 Dim wb1 As Worksheet, r1 As Range Dim N As Integer, i As Integer Dim mycount As Long   Set wb1 = ThisWorkbook.Worksheets("請求書") mycount = Range("B111").CurrentRegion.Rows.Count Cells(111 + mycount, 2).Select ActiveCell.Offset(0, 0).Value = wb1.Range("C60").Value ActiveCell.Offset(0, 1).Value = wb1.Range("C61").Value ActiveCell.Offset(0, 12).Value = wb1.Range("C66").Value ActiveCell.Offset(0, 13).Value = wb1.Range("C74").Value ActiveCell.Offset(0, 14).Value = wb1.Range("C75").Value ActiveCell.Offset(0, 15).Value = wb1.Range("C84").Value ActiveCell.Offset(0, 16).Value = wb1.Range("C85").Value ActiveCell.Offset(0, 20).Value = wb1.Range("C69").Value ActiveCell.Offset(0, 22).Value = wb1.Range("C68").Value ActiveCell.Offset(0, 23).Value = wb1.Range("C76").Value ActiveCell.Offset(0, 24).Value = wb1.Range("C77").Value Exit Sub

  • VLookupで一致しなかった時のVBAでの処理

    On Error ~を使わないで、 VLookup()で一致しなかった時の処理をさせたいのですが どのように記述すればよいでしょうか。 例えば、以下のようなコードの場合、 一致したデータがない時にyに-1を代入するには 以下のコードをどのように記述すればよいのでしょうか。 --------------------- Dim x As Integer Dim y As String x = 7 y = Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False) --------------------- 以下はいずれもエラーになりますが、以下のような感じで処理がしたいです。 --------------------- If IsError(Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False)) Then  y = -1 Else  y = Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False) End If --------------------- If Application.WorksheetFunction.IsNA(Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False)) Then  y = -1 Else  y = Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False) End If --------------------- y = Application.WorksheetFunction.IfError(Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False), -1) --------------------- なお、以下のように本来エラーではない処理で On Error Resume Nextを使うのは、 本当のエラーの処理と混同するため不可 --------------------- On Error Resume Next y = Application.WorksheetFunction.VLookup(x, Worksheets("Sheet1").Range("A1:B100"), 2, False) If Err <> 0 Then y = -1 On Error GoTo 0 ---------------------

  • VBAでVlookup関数を組もうとしていますがエラーが出ます。VBAに詳しい方、教えてください

    VBAでvlookup関数を下のように組みましたが、(1)でエラーが出ます。VBAに詳しい方、教えてください。 Sub VLLOKUPによる表の検索4() Dim mykensakuchi Dim mykensakuhan Dim gyo As Integer (1) mykensakuchi = Worksheets("sheet1").Range("a" & gyo).Value mykensakuhan = Worksheets("sheet2").Range("b2:e9") saikagyo = Worksheets("sheet1").Range("a" & Rows.Count).End(xlUp).Row gyo = 2 For gyo = saikagyo To 1 Step -1 With Application.WorksheetFunction Range("b:gyo").Value = .VLookup(mykensakuchi, mykensakuhan, 2, False) End With Next End Sub

  • VBAでoutlook365が起動しません。

    VBAでoutlook365が起動しません。EXCELまたは、OUTLOOK設定がおかしいのでしょうか。 メール一括作成のボタンを押しても『記載に誤りが無いことを確認しましたか?』『"送信完了しました』のメッセージは出るのですが、outlookが起動しませんし下書ホルダにも保存されません。 EXCELは他のマクロは動作しますし、Outlookはセキュリティ(トラストセンター)設定も有効です。どなたかご教示いただけますようお願いいたします。 添付でEXCEL画面の画像と下記に対象の記述を記します。 ------------------------------------------------------- Sub メール作成() Dim objOutlook As Outlook.Application Dim objMail As Outlook.MailItem Dim wsMail As Worksheet Dim filead As String Dim tenp1 As String Dim tenp2 As String 'メール立ち上げ Set objOutlook = New Outlook.Application Set wsMail = ThisWorkbook.Sheets("リスト") '添付ファイルのアドレスを変数にする filead = Worksheets("リスト").Range("B3").Value '共通添付データのアドレスを読む tenp1 = filead & "\" & Worksheets("リスト").Range("B4") tenp2 = filead & "\" & Worksheets("リスト").Range("B5") Dim kobetsumail1 As String Dim kobetsumail2 As String Dim adrs1 As String Dim asrs2 As String '変数iを設定。最初は1 Dim i As Long i = 1 '送付前の確認メッセージ Dim rc As Long rc = MsgBox("記載に誤りが無いことを確認しましたか?", vbYesNo + vbQuestion, "確認") If rc = vbNo Then MsgBox "中断しました" End End If '基準となるセルを選択 Worksheets("リスト").Select Range("B7").Select '取引先名が書かれているB列が空欄になるまで続ける Do Until ActiveCell.Offset(i, 0).Value = "" '送付チェック欄が○なら作業を続ける If ActiveCell.Offset(i, 2).Value = "○" Then Set objMail = objOutlook.CreateItem(olMailTtem) '個別メールのデータ名称を読む Dim CC12(1) As String CC12(0) = ActiveCell.Offset(i, 6).Value CC12(1) = ActiveCell.Offset(i, 8).Value 'メールを作成する With wsMail objMail.to = ActiveCell.Offset(i, 4).Value objMail.CC = Join(CC12, ";") objMail.Subject = Range("B1").Value objMail.Bodyformat = olFormatPlain objMail.body = Range("B7").Offset(i, 0) & vbCrLf & Range("E7").Offset(i, 0) & "様" & vbCrLf & vbCrLf & Range("B2").Value & vbCrLf & vbCrLf kobetsumail1 = ActiveCell.Offset(i, 9).Value asrs1 = filead & "\" & kobetsumail1 kobetsumail2 = ActiveCell.Offset(i, 10).Value asrs2 = filead & "\" & kobetsumail2 If Range("B4").Value <> "" Then objMail.Attachments.Add tenp1 End If If Range("B5").Value <> "" Then objMail.Attachments.Add tenp2 End If If ActiveCell.Offset(i, 9).Value <> "" Then objMail.Attachments.Add asrs1 End If If ActiveCell.Offset(i, 10).Value <> "" Then objMail.Attachments.Add asrs2 End If objMail.Display End With End If i = i + 1 Loop Set objOutlook = Nothing MsgBox "送信完了しました" End Sub

専門家に質問してみよう