VBAは値が一致する2つのブックから値を取得しますか？

Question

シナリオ

私は、私はシート上のセルI8の値を3つのワークブック私のマスターブックで

Master 
Planner 
Phonebook 

を持っている1.

マスター（シート1）

I8 = 2 

シート2には次の空の列があります。

マスター（シート2）

Column A (number)  Column B (Supplier)  Column C (Contact) 

私はプランナーのワークブックや電話帳、ブックの両方からのデータでこれらのカラムを投入する予定。

私のプランナーで

、私は列のN.の列A内の数値とサプライヤーのリストを持って、私は（セルI8の値と一致し、私のプランナーのワークブックからすべてのサプライヤーをコピーしようとしています

Numbers  Supplier  
2   A 
2   B 
2   C 
3   D 
4   E 
2   F 

この例では2）です。

私は、列Aに番号（2）を貼り付けて、マスタワークブックの列Bにサプライヤ名を貼り付けています。

私のコードはすでにこれらの値をコピーして貼り付けています。 （plannerからmasterの他の列にも他の値をコピーしていますが、この質問については関係ありません）。

私のコードのこの部分はうまくいきます。

問題

サプライヤーは、マスターワークブックの列Bに貼り付けるされたら - 私も自分のワークブック電話帳から各サプライヤの連絡先の名前をコピーしたいです。

私の電話帳ワークブックにはシートがあり、サプライヤはアルファベット順に記載されています。

電話帳：

Supplier (Column A)  Contact Name (Column C) 

    A       Linda 
    Aa       Dave 
    Aa       Terry 
    AB       James 

A | B | C | D etc... <----- Sheets 

Iは、列B（マスタ）で供給者名と一致業者名の電話帳の列Aの各シートに見える必要があります。

サプライヤー名が、その後、私はマスターワークブックの列C.

へのカラムCに連絡先の名前をコピーしたいと一致した場合私の結果は、この

マスター（シート2）

Column A (number)  Column B (Supplier)  Column C (Contact) 
2      A      Linda 
2      A      Linda 

のようになります。

ここに私のコードです：何らかの理由で

Option Explicit 

Sub CreateAnnounce() 

Dim WB As Workbook 
Dim WB2 As Workbook 
Dim i As Long 
Dim i2 As Long 
Dim j As Long 
Dim LastRow As Long 
Dim j2 As Long 
Dim LastRow2 As Long 
Dim ws As Worksheet 

'Open Planner 
On Error Resume Next 
Set WB = Workbooks("2017 Planner.xlsx") 
On Error GoTo 0 
If WB Is Nothing Then 'open workbook if not open 
    Set WB = Workbooks.Open("G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\8. 2017\2017 Planner.xlsx") 
End If 

'Open PhoneBook 
On Error Resume Next 
Set WB2 = Workbooks("Phone Book for Food Specials.xls") 
On Error GoTo 0 
If WB2 Is Nothing Then 'open workbook if not open 
    Set WB2 = Workbooks.Open("G:\BUYING\Food Specials\1. General\Phone Book\Phone Book for Food Specials.xls") 
End If 

' ======= Edit #2 , also for DEBUG ====== 
With WB.Worksheets(1) 
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
    j = 2 

    For i = 1 To LastRow 


     ' === For DEBUG ONLY === 
     Debug.Print CInt(ThisWorkbook.Worksheets(1).Range("I8").Value) 


     If CInt(ThisWorkbook.Worksheets(1).Range("I8").Value) = .Range("A" & i).Value Then ' check if Week No equals the value in "A1" 

       ThisWorkbook.Worksheets(2).Range("A" & j).Value = .Range("A" & i).Value 
       ThisWorkbook.Worksheets(2).Range("B" & j).Value = .Range("N" & i).Value 
       ThisWorkbook.Worksheets(2).Range("H" & j).Value = .Range("K" & i).Value 
       ThisWorkbook.Worksheets(2).Range("I" & j).Value = .Range("L" & i).Value 

       ThisWorkbook.Worksheets(2).Range("J" & j).Value = .Range("M" & i).Value 
       ThisWorkbook.Worksheets(2).Range("K" & j).Value = .Range("G" & i).Value 

       ThisWorkbook.Worksheets(2).Range("L" & j).Value = .Range("O" & i).Value 
       ThisWorkbook.Worksheets(2).Range("M" & j).Value = .Range("P" & i).Value 

       ThisWorkbook.Worksheets(2).Range("N" & j).Value = .Range("W" & i).Value 
       ThisWorkbook.Worksheets(2).Range("O" & j).Value = .Range("Z" & i).Value 



       'Retrieve Contact Details for supplier 

       'Worksheet 1 



       'Retrieve Contact Details for supplier 
      With WB2.Worksheets(2) 
      LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row 
      j2 = 2 

      For i2 = 1 To LastRow2 
      Dim rngToFill As Range 
      Set rngToFill = .Range("C2") 

      Do 

      Debug.Print ThisWorkbook.Worksheets(2).Range("B" & j2).Value 

      If ThisWorkbook.Worksheets(2).Range("B" & j2).Value Like .Range("A" & i2).Value Then ' check if Company equals the value in "B1 Phonebook" 

      ThisWorkbook.Worksheets(2).Range("C2").Value = .Range("C" & i2).Value 

      Set rngToFill = rngToFill.Offset(1, 0) 


      End If 

      Loop 

      Next i2 
      End With 










      'Retrieve Contact Details for supplier - END 




      End If 

    Next i 
End With 


End Sub 

、コ最初の行の連絡先名を1つだけマスターブックにコピー/貼り付けしています。

私はまた、現時点では1枚しか見ていないことを認識しています。

With WB2.Worksheets(2) 

このコードでは、すべてのサプライヤの連絡先の名前をすべてのシートに明示する必要があります。

私が間違っている場所と、このコードを動作させる方法を教えてもらえますか？前もって感謝します。

EDIT：

私は、ユーザー@BjornBogersによって

を提案し、コードを構成している「サプライヤー

  Dim FoundCellRng As Range 
      Dim ContactValue As String 
      Dim SearchStr As String 

      For i2 = 1 To 26 
       'Assuming --> ThisWorkbook.Worksheets(2).Range("B1").Value is what you are looking for? 
       SearchStr = ThisWorkbook.Worksheets(2).Range("B2").Value 
       Set FoundCellRng = WB2.Worksheets(i2).Range("A2:A200").Find(SearchStr) 
       If (FoundCellRng Is Nothing) Then 
        'Didn't find anything 
       Else 
        'We found it 
        ContactValue = WB2.Worksheets(i2).Cells(FoundCellRng.Row, FoundCellRng.Column + 2).Value 
        ThisWorkbook.Worksheets(2).Range("C" & j).Value = ContactValue 
        Exit For 
       End If 
      Next i2 


      'Retrieve Contact Details for supplier - END 

のための連絡先の詳細を取得しかし、これは同じことを行い、唯一の連絡先名があります一番上の行には何も入力されていません。

EDIT 2：

R3uK @コードを提供して、私は次の問題を取得しているようだ：

サプライヤーの名前と他の値が正しく全体でコピーされていません。 同じ値が何度も繰り返されるようです。

何らかの理由で、このコードで別のシートが作成されますか？このシートは何ですか？

コードは非常に遅く、私は20分以上待たいます。 これをスピードアップする方法はありますか？

Answer 1

は、私はこれをテストしていませんが、あなたは次のよう試みることができる：

   Dim FoundCellRng As Range 
       Dim ContactValue As String 
       Dim SearchStr As String 

       For i = 1 To 26 
        'Assuming --> ThisWorkbook.Worksheets(2).Range("B1").Value is what you are looking for? 
        SearchStr = ThisWorkbook.Worksheets(2).Range("B1").Value 
        Set FoundCellRng = WB2.Worksheets(i).Range("A1:A100").Find(SearchStr) 
        If (FoundCellRng Is Nothing) Then 
         'Didn't find anything 
        Else 
         'We found it 
         ContactValue = WB.Worksheets(i).Cells(FoundCellRng.Row, FoundCellRng.Column + 2).Value 
         Exit For 
        End If 
       Next i 

Answer 2

Sub CreateAnnounce() 
Dim WbMaster As Workbook 
Dim wSMaster1 As Worksheet 
Dim wSMaster2 As Worksheet 
Dim wSMastTemp As Worksheet 
Dim WbPlan As Workbook 
Dim wSPlan1 As Worksheet 
Dim WbPhone As Workbook 
Dim wSPhone As Worksheet 
Dim i As Long 
Dim j As Long 
Dim LastRow As Long 
Dim rngToFill As Range 
Dim rngToChk As Range 


Set WbMaster = ThisWorkbook 
Set wSMaster1 = WbMaster.Sheets(1) 
Set wSMaster2 = WbMaster.Sheets(2) 
Set wSMastTemp = WbMaster.Sheets.Add 
'''Open Planner 
Set WbPlan = GetWB("2017 Planner.xlsx", "G:\BUYING\Food Specials\2. Planning\1. Planning\1. Planner\8. 2017\2017 Planner.xlsx") 
Set wSPlan1 = WbPlan.Sheets(1) 
'''Open PhoneBook 
Set WbPhone = GetWB("Phone Book for Food Specials.xls", "G:\BUYING\Food Specials\1. General\Phone Book\Phone Book for Food Specials.xls") 

With wSPlan1 
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
    j = 2 
    For i = 1 To LastRow 
     '''Check if Week No equals the value in "A1" 
     If CInt(wSMaster1.Range("I8").Value) = .Range("A" & i).Value Then 
      wSMaster2.Range("A" & j).Value = .Range("A" & i).Value 
      wSMaster2.Range("B" & j).Value = .Range("N" & i).Value 
      wSMaster2.Range("H" & j & ":J" & j).Value = .Range("K" & i & ":M" & i).Value 
      wSMaster2.Range("K" & j).Value = .Range("G" & i).Value 
      wSMaster2.Range("L" & j & ":M" & j).Value = .Range("O" & i & ":P" & i).Value 
      wSMaster2.Range("N" & j).Value = .Range("W" & i).Value 
      wSMaster2.Range("O" & j).Value = .Range("Z" & i).Value 
      '''Store those infos for next results 
      wSMastTemp.Cells.Clear 
      wSMastTemp.Range("A1:O1").Value = wSMaster2.Range("A" & j & ":O" & j).Value 

      '''Retrieve Contact Details for supplier 
      Set rngToFill = wSMaster2.Range("C" & j) 
      For Each wSPhone In WbPhone.Sheets 
       With wSPhone 
        '''Define properly the Find method to find all 
        Set rngToChk = .Columns(1).Find(What:=wSMaster2.Range("B" & j).Value, _ 
           After:=.Cells(1, 1), _ 
           LookIn:=xlValues, _ 
           LookAt:=xlWhole, _ 
           SearchOrder:=xlByRows, _ 
           SearchDirection:=xlNext, _ 
           MatchCase:=False, _ 
           SearchFormat:=False) 

        '''If there is a result, keep looking with FindNext method 
        If Not rngToChk Is Nothing Then 
         FirstAddress = rngToChk.Address 
         Do 
          '''Transfer the cell value to the master 
          rngToFill.Value = rngToChk.Offset(, 2).Value 

          '''Go to next row on the template for next Transfer 
          Set rngToFill = rngToFill.Offset(1, 0) 
          '''Copy the Info from 1st row for the next result 
          wSMaster2.Range("A" & rngToFill.Row & ":O" & rngToFill.Row).Value = wSMastTemp.Range("A1:O1").Value 

          '''Look until you find again the first result in that sheet 
          Set rngToChk = .Columns(1).FindNext(rngToChk) 
         Loop While Not rngToChk Is Nothing And rngToChk.Address <> FirstAddress 
        Else 
        End If 
       End With 'wSPhone 
      Next wSPhone 
      '''Restart to fill from the next available row 
      j = rngToFill.Row 
      '''Clean Data that was there for the next result of this test 
      wSMaster2.Range("A" & j & ":O" & j).ClearContents 
     End If 
    Next i 
End With 

Application.DisplayAlerts = False 
wSMastTemp.Delete 
Application.DisplayAlerts = True 
End Sub 


Public Function GetWB(FileName As String, FileFullPath As String) As Workbook 
    On Error Resume Next 
    Set GetWB = Workbooks(FileName) 
    On Error GoTo 0 
    If GetWB Is Nothing Then 'open workbook if not open 
     Set GetWB = Workbooks.Open(FilePath) 
     DoEvents 
    End If 
End Function