Любой возможный код VBA для двойного и последовательного нумерации имен в Excel?

Question

Есть ли какой-нибудь возможный способ взять список предметов или имен, например:

Apples
Oranges
Grapes
Watermelons

И Excel дважды удваивает эту информацию и последовательно нумерует ее следующим образом:

Apples1
Apples2
Oranges1
Oranges2
Grapes1
Grapes2
Watermelons1
Watermelons2

Я немного знаю VBA, но не могу понять, как бы я начал это.

Answer 1

Я бы начал с написания общей функции, которая выводит имена (переданные как variant array) заданное количество раз:

Public Sub OutputNames(ByVal TimesToOutput As Integer, ByRef names() As Variant)
    Dim nameIndex As Integer, outputIndex As Integer

    For nameIndex = LBound(names) To UBound(names)
        For outputIndex = 1 To TimesToOutput
            Debug.Print names(nameIndex) & outputIndex
        Next outputIndex
    Next nameIndex

End Sub

Здесь вы можете увидеть саб, который проверяет это:

Public Sub testOutputNames()
    Dim names() As Variant
    names = Array("Apples", "Oranges", "Grapes", "Watermelons")
    OutputNames 2, names
End Sub

, который дает вам этот вывод:

Apples1
Apples2
Oranges1
Oranges2
Grapes1
Grapes2
Watermelons1
Watermelons2

Answer 2

Вы можете указать, где вы хотите прочитать, и где вы хотите начать писать и сколько раз вы хотите повторить! Просто измените код:

Sub DoRepeat()
Dim repeatTimes As Integer
Dim rng As Range, cell As Range

repeatTimes = 2

Set cellsToRead = Range("A1:A3")
Set cellStartToWrite = Range("B1")

For Each cell In cellsToRead
    For i = 1 To repeatTimes
        cellStartToWrite.Value = cell.Value + CStr(i)
        Set cellStartToWrite = Cells(cellStartToWrite.Row + 1, cellStartToWrite.Column)
    Next
Next cell

End Sub

Answer 3

Поскольку кажется, что требуется более динамичный подход, попробуйте это. Функция DoubleNames будет возвращать дублирующиеся имена N количество раз, указанное в параметре DuplicateCount. Он вернет коллекцию, которую вы можете легко сбросить в диапазон при необходимости.

Public Function DoubleNames(ByVal DataRange As Excel.Range, DuplicateCount As Long) As Collection
    Set DoubleNames = New Collection
    Dim dict     As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim i        As Long
    Dim DataItem As Excel.Range
    Set DataRange = DataRange.SpecialCells(xlCellTypeConstants)

    For Each DataItem In DataRange
        For i = 1 To DuplicateCount
            If Not dict.Exists(DataItem.Value) Then
                DoubleNames.Add (DataItem.Value & "1")
                dict.Add DataItem.Value, 1
            Else
                dict(DataItem.Value) = dict(DataItem.Value) + 1
                DoubleNames.Add (DataItem.Value & dict(DataItem.Value))
            End If
        Next
    Next
End Function

Sub ExampleUsage()
    Dim item As Variant
    Dim rng As Range: Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1:A5")
    For Each item In DoubleNames(rng, 5)
        Debug.Print item
    Next
End Sub