遍历范围并根据计数附加值

searchnetworking和SO，但找不到帮助我的答案。 希望直接的问题能引起社区的启发。

我想创build代码，通过范围（列标题），检测重复，然后附加每个重复的计数。

例如，我的列标题看起来像这样：

• 供应商
• 追踪号码
• 显示在
• types
• 通话报告标志
• types
• 应有
• 由…制作
• 创build
• 由…制作
• 创build

运行代码后，我希望他们看起来像这样：

• 供应商
• 追踪号码
• 显示在
• types1
• 通话报告标志
• types2
• 应有
• 创build者1
• Created1
• 创build者2
• Created2

不重复被留下，重复已经被当前计数附加。

我已经尝试了一些代码，它使用'我的范围内的每个单元格'的计数重复＃，但一旦它附加计数，它不再看到它是一个重复，所以当它移动到下一个单元格时不要追加。

这里是我的代码（尽pipe我想我可能需要从一个不同的策略开始）：

Sub TestSub（）

Dim Counter As Integer Dim Cell As Range Dim Headers As Range Set Headers = Worksheets("TEST SHEET").UsedRange.Rows("1:1") Counter = 1 For Each Cell In Headers.Cells.Value If WorksheetFunction.CountIf(Headers, Cell.Value) > 1 Then Cell.Value = Cell.Value & Counter End If Counter = Counter + 1 Next Cell End Sub 

希望有人能帮忙。

Answer 1

这使用这个公式的基础：

 =IF(COUNTIF(1:1,A1)>1,A1&COUNTIF($A$1:A$1,A1),A1) 

做你想做的事：

 Sub TestSub() Dim Cell As Range Dim Headers As Range Dim Headers2 As Range With Worksheets("TEST SHEET") Set Headers = .UsedRange.Rows("1:1") Headers.Copy .Range("A" & Worksheets("Sheet3").Rows.Count) Set Headers2 = .UsedRange.Rows(.Rows.Count & ":" & .Rows.Count) For Each Cell In Headers.Cells If WorksheetFunction.CountIf(Headers2, Cell.Value) > 1 Then Cell.Value = Cell.Value & WorksheetFunction.CountIf(Range("A" & .Rows.Count, .Cells(.Rows.Count, Cell.Column)), Cell.Value) End If Next Cell Headers2.ClearContents End With End Sub 

我们需要将标题复制到另一个位置，以在COUNTIF（）中使用。 否则，一旦第一次被改变，其他的将不会相同，并且countif不能find多于一个。