Vba 基于Excel循环条件的连接

我是excel宏的新手，需要您的帮助来解决我的一个基于条件的连接问题

我将在下面的简单场景中解释问题：

在我的工作表中，A列包含客户名称，B列包含国家名称。随附的excel屏幕打印供参考（C列和D列将是我的预期结果）

在A列中，单个客户名称可以重复，因为他可以有多个国家/地区表示

在B列中，国家如屏幕图所示

我的预期结果在C列和D列中看起来很相似，如图所示

我可以使用索引做C列，我可以从A列中得到唯一的值

对于D列，我希望所有国家/地区都会根据a列中相应的客户用“/”连接和分隔。我尝试了一些vlookups和索引，但我不能 去做吧

---

如果您能提供如何实现的建议（函数/宏），这将非常有帮助。

我是一个低级vba用户，因此我承认，我相信有人可以做得比这更好。添加一个按钮，然后单击该按钮，或将其添加到工作表中，无论何时选择触发该按钮，都会发生：

Option Explicit
Sub listout()

  'declare your variables
  Dim wbk As Workbook
  Dim ws1 As Worksheet
  Dim cprange As Range
  Dim rmrange As Range
  Dim bottomRow As Long
  Dim row As Range
  Dim countname As Variant
  Dim copyname As Variant
  Dim nametoRow As Long

  'speed up process
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False

  'set what the variables are
  Set wbk = ThisWorkbook
  Set ws1 = wbk.Worksheets("Names List")
  bottomRow = ws1.Range("A1").End(xlDown).row

  'get ird of any excisting values
  ws1.Range("C1:D100").ClearContents

  'Set the range of the names that you want to copy, and put them into column C
  Set cprange = ws1.Range(Range("A1"), Range("A1" & bottomRow))
  ws1.Range(Range("C1"), Range("C1" & bottomRow)) = cprange.Value

  'then remove all the duplicates
  Set rmrange = ws1.Range(Range("C1"), Range("C1" & bottomRow))
  rmrange.RemoveDuplicates Columns:=1, Header:=xlNo

  'redclare the range as it will be shorter because you got rid of load sof duplicates
  Set rmrange = ws1.Range(Range("C1"), Range("C1").End(xlDown))

  'loop though each name in the 'unique' list and loop through their names in the original data then add the country to their new location in column D
  For Each copyname In rmrange
    For Each row In cprange
      nametoRow = ws1.Application.WorksheetFunction.Match(copyname, rmrange, False)
      countname = row.Offset(0, 1)
      If row.Value = copyname Then
        If Trim(ws1.Range("D" & nametoRow) & vbNullString) = vbNullString Then
          ws1.Range("D" & nametoRow) = countname
        Else
          ws1.Range("D" & nametoRow) = ws1.Range("D" & nametoRow) & "/ " & countname
        End If
      End If
    Next row
  Next copyname

  'turn these back on otherwise it messes with your computer/excel
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

---

这里有一个更有效的方法。

高级过滤器从A列中删除重复项，粘贴到C列

设定必要的范围

循环遍历每个唯一的名称

构建字符串

粘贴字符串

循环4-6直到完成

假设/操作：您在A、B、C和D列上有标题。如果您有重复的国家/地区，则该国家/地区将在字符串上显示两次。您需要将

“Sheet1”

更改为第三行的工作表名

通常您需要使用

.Find

方法检查是否找到了您的值，但是下面的逻辑不允许找不到单元格，因为它正在通过过滤器确定的值循环。因为在过滤对象的来源范围内找不到该对象，所以这不会产生任何影响

---

---

欢迎光临！这是一个程序员编写自己的代码并在试图自己解决某个特定问题后与之共享问题的网站。如果，之后，你有一个特定的问题，请分享你的帖子和一些背景信息。一些好的阅读材料让你开始：“以及提示和/或重复你之前的问题，这个问题有一个答案：一个名字有可能与同一个国家匹配两次吗？

John

能被映射到

USA

两次吗？谢谢..你的脚本在我的工作表中有效。是否可以使用此脚本调用单个excel文件中的其他工作表。假设A、B、C列在表1中，C和D列在表2中。我想用这个脚本在sheet2的D列中打印连接的结果。还请注意，sheet2中的C列包含其他行（即其他客户），并且不会为这些其他客户打印结果是的，这是可能的。我尝试更改“ws=ThisWorkbook.Sheets”（“Sheet1”）和单元格编号，但无法获得预期结果。如果你能提供一些详细的信息，我将不胜感激。如果你需要这个，你应该把它包括在你的原始问题中。这听起来像是白白写的，因为它不是你需要的——即使它满足了你的问题。编辑您的问题以准确地包含您需要的内容，我将再次编辑回答我已为我的上述查询创建了一个单独的问题：

Option Explicit

Sub CountryList()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")

Dim FoundCell As Range, SearchRange As Range, Names As Range, SearchCell As Range
Dim MyString As String, i As Long

Set SearchRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
    SearchRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("C2"), Unique:=True
    ws.Range("C2").Delete Shift:=xlShiftUp

Set Names = ws.Range("C2:C" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)

For Each SearchCell In Names
    Set FoundCell = SearchRange.Find(SearchCell)
        For i = 1 To Application.WorksheetFunction.CountIf(SearchRange, SearchCell)
            MyString = MyString & FoundCell.Offset(, 1) & "/"
            Set FoundCell = SearchRange.FindNext(FoundCell)
        Next i
    SearchCell.Offset(, 1) = Left(MyString, Len(MyString) - 1)
    MyString = ""
Next SearchCell

End Sub