VBA將值複製到其他工作簿，使用複製的值作爲參考複製其他值？

Question

我有兩個excel工作簿。

一個工作簿稱爲Master.xlsm

，看起來像這樣：

我也叫template.xlsx

，看起來像這樣的工作簿：

讓我建立上下文。

主工作簿包含公司名稱的B列的清單和項目數列H.

Company Name  Item 
Intertrade  111 
B     222 
Intertrade  333 
C     444 
B     555 
E     666 

我希望我的VBA代碼，通過在B列 每個公司名稱環路，則列表，我想在我template.xlsx工作簿複製/粘貼的公司名稱到小區C12中，像這樣：

之前在B列中masterworkbook上移動到下一個公司名稱在列表中向下。我要檢查是否有公司名稱的B列更多的情況下

所以在這個例子中，公司國貿「兩次出現在B列 因此它在列H.

兩項數字

我想複製公司名稱與剛剛複製到template.xlsx中單元格c12'Intertrade'中的公司名稱匹配的列H中的每個項目編號。

應按要求在每個單元格A30：A39中輸入項目編號。

然後模板工作簿應該保存一個名爲公司名稱的文件名。

代碼應該循環並重新開始。因此，下一個公司名稱應該被複制到單元格c12的模板中，所有匹配的項目編號都應該輸入單元格A30：A39（如適用），並保存工作簿。

這裏是我的代碼：

Sub test() 
    Dim wbMaster As Workbook 
    Dim wbTemplate As Workbook 
    Dim wStemplaTE As Worksheet 
    Dim i As Long 
    Dim k As Long 
    Dim r As Range 
    Dim rngToChk As Range 
    Dim rngToFill As Range 
    Dim CompName As String 

    '''Reference workbooks and worksheet 
    Set wbMaster = ThisWorkbook 
    Set wbTemplate = Workbooks("template.xlsx") 
    Set wStemplaTE = wbTemplate.Sheets(1) 

    '''Loop through Master Sheet to get company names 
    With wbMaster.Sheets(2) 
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
     '''Run Loop on Master 
     For i = 1 To LastRow 
      '''Found the initial value company name 
      Set rngToChk = .Range("B" & i) 
      CompName = rngToChk.Value 
      '''Set Company Name to Template 
      wStemplaTE.Range("C12").Value = CompName 

      '''This is where you'd define Where To Look 
      k = 1 
      '''While the company name matches 
      Do While rngToChk.Value = rngToChk.Offset(k, 0).Value 

       k = k + 1 
      Loop 
      k = k - 1 
      Set rngToChk = .Range(rngToChk, rngToChk.Offset(k, 0)) 

      '''Add Item Desc 
      Set rngToFill = wStemplaTE.Range("A30") 
      '''Run Second Loop. Lookup all item numbers for company name in template 
      For Each r In rngToChk 

       '''Copy the cell value 
       rngToFill.Value = r.Offset(, 6).Value 
       '''Go to next row for next "paste" 

       Set rngToFill = rngToFill.Offset(1, 0) 

      Next r 


      file = AlphaNumericOnly(CompName) 
      wbTemplate.SaveCopyAs Filename:="G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\test\" & file & ".xlsx" 
     Next i 
    End With 'wbMaster.Sheets(2) 
End Sub 



Function AlphaNumericOnly(strSource As String) As String 
    Dim i As Integer 
    Dim strResult As String 

    For i = 1 To Len(strSource) 
     Select Case Asc(Mid(strSource, i, 1)) 
      Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space 
       strResult = strResult & Mid(strSource, i, 1) 
     End Select 
    Next 
    AlphaNumericOnly = strResult 
End Function 




Function FindAll(SearchRange As Range, _ 
       FindWhat As Variant, _ 
       Optional LookIn As XlFindLookIn = xlValues, _ 
       Optional LookAt As XlLookAt = xlWhole, _ 
       Optional SearchOrder As XlSearchOrder = xlByRows, _ 
       Optional MatchCase As Boolean = False, _ 
       Optional BeginsWith As String = vbNullString, _ 
       Optional EndsWith As String = vbNullString, _ 
       Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range 

       End Function 

用戶@ R3uK已與該代碼大量幫助，但出於某種原因，該代碼似乎是複製屬於不同的公司名稱項目編號，有時重複相同項目編號。

請有人可以解釋爲什麼這是，並幫助我得到這段代碼做我需要它？在此先感謝

Answer 1

Sub test() 
    Dim wbMaster As Workbook 
    Dim wbTemplate As Workbook 
    Dim wStemplaTE As Worksheet 
    Dim i As Long 
    Dim LastRow As Long 
    Dim rngToChk As Range 
    Dim rngToFill As Range 
    Dim CompName As String 
    Dim TreatedCompanies As String 
    Dim FirstAddress As String 
    '''Reference workbooks and worksheet 
    Set wbMaster = ThisWorkbook 

    '''Loop through Master Sheet to get company names 
    With wbMaster.Sheets(2) 
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
     '''Run Loop on Master 
     For i = 2 To LastRow 
      '''Company name 
      Set rngToChk = .Range("B" & i) 
      CompName = rngToChk.Value 

      If InStr(1, TreatedCompanies, CompName) Or CompName = vbNullString Then 
       '''Company already treated, not doing it again 
      Else 
       '''Open a new template 
       Set wbTemplate = Workbooks.Open("C:\template.xlsx") 
       Set wStemplaTE = wbTemplate.Sheets(1) 

       '''Set Company Name to Template 
       wStemplaTE.Range("C12").Value = CompName 
       '''Add it to to the list of treated companies 
       TreatedCompanies = TreatedCompanies & "/" & CompName 
       '''Define the 1st cell to fill on the template 
       Set rngToFill = wStemplaTE.Range("A30") 

       With .Columns(2) 
        '''Define properly the Find method to find all 
        Set rngToChk = .Find(What:=CompName, _ 
           After:=rngToChk.Offset(-1, 0), _ 
           LookIn:=xlValues, _ 
           LookAt:=xlWhole, _ 
           SearchOrder:=xlByColumns, _ 
           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 template 
          rngToFill.Value = rngToChk.Offset(, 6).Value 
          '''Go to next row on the template for next Transfer 
          Set rngToFill = rngToFill.Offset(1, 0) 

          '''Look until you find again the first result 
          Set rngToChk = .FindNext(rngToChk) 
         Loop While Not rngToChk Is Nothing And rngToChk.Address <> FirstAddress 
        Else 
        End If 
       End With '.Columns(2) 

       File = AlphaNumericOnly(CompName) 
       wbTemplate.SaveCopyAs Filename:="G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\test\" & File & ".xlsx" 
       wbTemplate.Close False 
      End If 
     Next i 
    End With 'wbMaster.Sheets(2) 
End Sub