VBA复制到其他工作簿的值，复制其他值使用复制值作为参考？

我有两个Excel工作簿。

一个名为Master.xlsm的工作簿

看起来像这样：

我也有一个名为template.xlsx的工作簿

看起来像这样：

让我build立上下文。

主工作簿包含列B中的公司名称列表和列H中的项目编号列表。

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

我希望我的vba代码循环访问B列中的每个公司名称。然后，我想将公司名称复制/粘贴到我的template.xlsx工作簿中的单元格C12中，如下所示：

在继续阅读下一个公司名称之前，在masterworksbook的B列中。 我想检查B列中是否有更多公司名称的实例

所以在这个例子中，公司的“Intertrade”在B列中出现两次。因此在H列中有两个项目编号。

我想复制公司名称与刚刚复制到template.xlsx中的单元格c12'Intertrade'中的公司名称相匹配的列H中的每个项目编号。

项目编号应根据需要input到每个单元格A30：A39中。

然后模板工作簿应该保存一个名为公司名称的文件名。

然后代码应该循环并重新开始。 因此，下一个公司名称应该复制到模板c12单元格中，所有匹配的项目编号应该input单元格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 

User @ 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