基于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方法找到了您的值，但以下逻辑不允许将单元格在遍历由filter确定的值时发现。不会这样，因为在它来自的范围内找不到过滤的对象。

---

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