重命名带有数字的字符串（如果该数字已经存在于VBA列中）

我有一列标题，有时包含重复项。我想设置将找到这些重复标题的代码，并在末尾添加一个数字，以使它们全部唯一。

例如，如果“ Proprietorship Concern1”出现两次，我希望第一个更改为“ Proprietorship Concern1”，第二个更改为“ Proprietorship Concern2”。如果没有重复的标题，则不要在其末尾附加任何数字。

每个标题后面都将有一个称为“地址”的“标题”。我需要重命名它们，以复制上面字段的值，并在最后添加“地址”。例如，“主题信息”下方字段中的“地址”将变为“主题信息地址”。

您可以从下面的示例数据中看到我正在努力实现的目标。

这将在具有1000条记录的文件上运行，并且由于我是VBA的新手，我正在寻求有关该解决方案的帮助。谢谢。

下面的代码应该可以满足您的所有需求。

由于此解决方案使用字典来存储标题，因此与Tom的解决方案相比，您不必在整列中搜索其他行的匹配项。

当涉及ADDRESS字段时，它只是复制上面的标头并在其末尾添加ADDRESS，因为上面的字段已经被格式化，这又使您不必不必要地检查和比较标题。

Public Sub renameHeaders()
Dim headerRange As Range
Dim headerCell As Range
Dim headerValue As String
Dim headerDict As Object
Set headerDict = CreateObject("Scripting.Dictionary")
'CHANGE SHEET1 NAME HERE TO YOUR SHEET
With Sheets("Sheet1") 'Get all headers
Set headerRange = .Range("A2:A" & .Cells(.Rows.Count,1).End(xlUp).Row)
End With
For Each headerCell In headerRange.Cells 'Check each header
headerValue = headerCell.Value
If headerValue = "ADDRESS" Then 'If "Address" simply add address to above value
headerCell.Value = headerCell.Offset(-1,0).Value & " ADDRESS"
Else
If headerDict.exists(headerValue) Then
'If header seen before start adding numbers
If IsNumeric(headerDict(headerValue)) Then
headerDict(headerValue) = headerDict(headerValue) + 1
Else
headerDict(headerValue).Value = headerValue & "1"
headerDict(headerValue).Offset(1,0).Value = headerValue & "1 ADDRESS"
headerDict(headerValue) = 2
End If
headerCell.Value = headerValue & headerDict(headerValue)
Else
'If not already seen leave header as is and add to dict
headerDict.Add headerValue,headerCell
End If
End If
Next headerCell
End Sub


尝试使用以下内容。将需要使用您的输入和输出进行更新

Sub test()
Dim rng As Range
Dim tmpStr As String
Dim concat As Boolean
Dim i As Long
' Update with your input range
With ActiveSheet
Set rng = .Range(.Cells(2,1),.Cells(.Cells(.Rows.Count,1).End(xlUp).Row,1))
End With
For i = 1 To rng.Rows.Count
tmpStr = vbNullString
cOncat= (i Mod 2 = 0)
If WorksheetFunction.CountIf(rng,rng(i - 1,1).Value2) > 1 Then
tmpStr = IIf(concat,1).Value2,rng(i,1).Value2) & _
WorksheetFunction.CountIf(Range(rng.Cells(1),1)),IIf(concat,1).Value2)) & _
IIf(i Mod 2 = 0," " & rng(i,vbNullString)
Else
tmpStr = IIf(concat,1).Value2) & IIf(concat,vbNullString)
End If
' Update with where you want data to be output to
rng(i,1).Offset(0,4).Value2 = tmpStr
rng(i,5).Value2 = rng(i,2).Value2
Next i
End Sub