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