2つのシートで共通する項目を突合せして、値を

Writer: admin Type: booksonline Date: 2019-03-06 00:00
2つのシートで共通する項目を突合せして、値を入れたい2つのシートに存在する値を確認し、共通する値に対して別セルに値を入れたいと考えています(oracleのPKと同様のことがしたいと考えています)シート1:No,NAME,ADD1,ABC,100001,ABC,100001,(null),100001,(null),100001,(null),100002,BBC,100002,BBC,100003,CCC,100003,CCC,100003,(null),100003,CCC,100003,(null),100004,DBB,100005,(null),100006,(null),100006,FBC,100006,FBC,10000シート2:No,STAT,NAME1,OK,ABC2,OK,BBC3,OK,CCC4,OK,DBB5,NG,EBC6,NG,FBC出力先(シート3):No,NAME,ADD1,ABC,100001,ABC,100001,ABC,100001,ABC,100001,ABC,100002,BBC,100002,BBC,100003,CCC,100003,CCC,100003,CCC,100003,CCC,100003,CCC,100004,DBB,100005,EBC,100006,FBC,100006,FBC,100006,FBC,10000 ⇒シート1の(null)の箇所に、シート1とNoが一致しているシート2のNAMEの値が入る状態 それ以外に変更点はない上記をvba(excel 2016)にて実施したいのですが、どのように実施すればよいのでしょうか?共感した0###以下でどうなりますか標準モジュールに以下を記述し、Samp1 を実行してみます各シートの表は、A1 ~ 出来上がっていることを前提に・・・やっていることは、Sheet2 の No をキーに、Name を Dictionary に覚えますSheet1 から3列分入手して、2列目が空白なら Dictionary に覚えていたものを転記この時、空白を判別しないで、無条件に転記しても良いかも?>      If (vA(i, 2) = "") Then>         vA(i, 2) = dic(vA(i, 1))>      End If↓      vA(i, 2) = dic(vA(i, 1))出来上がったものを Sheet3 に書き出して※ Sheet3 は綺麗にして・・・やっていないので・・・どうなりますかOption ExplicitPublic Sub Samp1()   Dim dic As Object   Dim vA As Variant   Dim i As Long   Set dic = CreateObject("Scripting.Dictionary")   With Worksheets("Sheet2")      With .Range("A1", .Cells(Rows.Count, "A").End(xlUp))         vA = .Resize(, 3).Value      End With   End With   For i = 2 To UBound(vA)      If (vA(i, 1) <> "") Then dic(vA(i, 1)) = vA(i, 3)   Next   With Worksheets("Sheet1")      With .Range("A1", .Cells(Rows.Count, "A").End(xlUp))         vA = .Resize(, 3).Value      End With   End With   For i = 2 To UBound(vA)      If (vA(i, 2) = "") Then         vA(i, 2) = dic(vA(i, 1))      End If   Next   With Worksheets("Sheet3")      .Range("A1").Resize(UBound(vA), 3).Value = vA   End With   Set dic = NothingEnd Subナイス0
###この回答は投票によってベストアンサーに選ばれました!###こんな感じでどうかな?Option ExplicitDim i As Long, MaxRow As LongDim RngLst As RangeSub syori()MaxRow = Sheets("Sheet1").Range("A1").End(xlDown).RowSet RngLst = Sheets("Sheet2").Range("A:C")For i = 1 To MaxRow Sheets("Sheet3").Cells(i, 1).Value = Sheets("Sheet1").Cells(i, 1).Value If Sheets("Sheet1").Cells(i, 2).Value = "" Then On Error Resume Next Sheets("Sheet3").Cells(i, 2).Value _ = WorksheetFunction.VLookup(Sheets("Sheet1").Cells(i, 1).Value, RngLst, 3, False) Else Sheets("Sheet3").Cells(i, 2).Value = Sheets("Sheet1").Cells(i, 2).Value End If Sheets("Sheet3").Cells(i, 3).Value = Sheets("Sheet1").Cells(i, 3).ValueNext iEnd Subナイス0
###もっとシンプルにならないのですか?Sub sample()Const cFormula As String = "=VLOOKUP(@,シート2!A:C,3,FALSE)"With Worksheets("シート3")Worksheets("シート1").Range("A:C").Copy .Range("A:A")With .Range("A1").CurrentRegion.Columns(2)If Application.CountBlank(.Cells) > 0 Then With .SpecialCells(xlCellTypeBlanks) .Formula = Replace(cFormula, "@", .Cells(1).Offset(, -1).Address(False, False)) End With .Value = .ValueEnd IfEnd WithEnd WithEnd Subナイス0
###SHEET1の D1に =IF(B1<>"",B1,VLOOKUP(A1,Sheet2!A:C,3,0)) といれ下にオートフィルD列を B列に 値貼り付けすれば 出来ます。

 

TAG