VBA 값이 일치하는 두 개의 통합 문서에서 값을 가져 옵니까?

Question

시나리오

나는, 나는 시트에 셀 I8에 값을 세 개의 통합 문서 내 마스터 통합 문서에서

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에 붙여 넣기 한 - 나는 또한 내 통합 전화 번호부에서 각 공급 업체의 연락처 이름을 복사 할.

내 전화 번호부 통합 문서에는 시트 A-Z가 있으며 공급 업체는이 시트 아래에 알파벳순으로 나열되어 있습니다.

번호부 :

I 칼럼 B에서 공급자 명칭 (마스터)에 일치하는 공급자 명칭에 대한 전화 번호부의 A 열에서 각 시트 해야하는

Supplier (Column A)  Contact Name (Column C) 

    A       Linda 
    Aa       Dave 
    Aa       Terry 
    AB       James 

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

. 공급 업체 이름은 내가

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

마스터 통합 문서를 열 C.

내 결과이

마스터 같아야합니다 (시트 2)에 걸쳐 열 C의 연락처 이름을 복사하려면 다음과 일치하는 경우

어떤 이유

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 

, 공동 :

여기 내 코드입니다 de는 첫 번째 행의 연락처 하나만을 마스터 통합 문서에 복사/붙여 넣기합니다.

나는 현재 한 시트 만보고있는 것으로 알고 있습니다.

With WB2.Worksheets(2) 

분명히 모든 공급 업체 연락처 이름을 보려면이 코드가 필요합니다.

누군가 내가 잘못 가고있는 곳과이 코드를 작동시키는 방법을 보여줄 수 있습니까? 미리 감사드립니다.

편집 : 사용자 @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 

그러나, 이것은 않는다 ' 맨 위 줄에 입력되지만 더 이상은 입력되지 않습니다.

편집 2 :

공급 업체 이름을 다른 값은 올바르게에서 복사되지 않습니다 R3uK 제공 @ 코드와

, 나는 다음과 같은 문제를 받고있는 것으로 보인다. 동일한 값이 열 I에서 반복해서 반복되는 것으로 보입니다.

어떤 이유로이 코드는 다른 시트를 생성합니까? 이 시트는 무엇을위한 것입니까?

코드는 매우 느리고 내가 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