基于Excel循环条件的连接[重复]

Question

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

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

在我的工作表中，A 列包含客户名称，B 列包含国家/地区名称。附上excel截图供参考（C列和D列将是我的预期结果）

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

在 B 列中，国家/地区如屏幕图所示。

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

我可以使用 INDEX 执行 C 列，并且能够从 A 列获取唯一值

对于 D 列，我期望结果会根据 A 列中的相应客户以“/”连接和分隔所有国家/地区。我尝试了一些 vlookup 和索引，但我无法 去做吧。

如果您能提供任何建议（功能/宏）如何实现，那将非常有帮助。

Answer 1

我是一个较低的中级 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

Answer 2

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

1. 高级过滤器从 Col A 中删除重复项，粘贴到 Col C 上
2. 设置必要的范围
3. 遍历每个唯一名称
4. 构建字符串
5. 粘贴字符串
6. 循环 4 - 6 直到完成

假设/行动： 您在 A、B、C 和 D 列上有标题。如果您有重复的国家/地区，则该国家/地区将显示两次在字符串上。您需要在第三行将"Sheet1" 更改为您的工作表名称。

通常您需要检查是否使用 .Find 方法找到了您的值，但以下逻辑不允许找不到单元格它循环通过过滤器确定的值。它不会因为在它来自的范围内找不到过滤的对象。

---

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