Excel vba Ошибка времени выполнения «13» в коде, который ранее работал

Question

У меня проблемы с приведенным ниже кодом в Excel vba.Ранее строка rSurname = Range ("A" + numrows).Value работала нормально, но я добавил в код проверку, существует ли уже значение в диапазоне «D: D», и теперь я получаю сообщение об ошибке времени выполнения 13

По сути, я пытаюсь сделать следующее:

1. Убедитесь, что фамилия имеет только 5 символов
2. Если фамилия содержит менее 5 символов, добавьте 5 к пробелам
3. Если фамилия имеет более 5 символов, обрезать до 5 символов
4. Добавить числовой суффикс с 4 цифрами (т. Е. 0001)
5. Проверить, что выход не существуети, если нет, выведите в диапазон «D: D»
6. Если значение существует, увеличьте суффикс и повторяйте проверку, пока значение не станет уникальным

Мой код ниже

Private Sub TestButton_Click()

Dim rSurname, rOutput, sLength, numrows, sFindString As String
Dim nSuffix As Integer
Dim rRange As Range
Dim iLength As Long



numrows = 1
    'Set Cell A2 as first cell range
    Range("A2").Select
    'Set loop to stop when en empty cell is reached
    Do
    'Increment numrows
    numrows = numrows + 1
    'Set Surname value
    rSurname = Range("A" + numrows).Value
    'Check Surname Letter Count and ensure 5 chars in Surname
    iLength = Len(rSurname)
    If iLength > 5 Then
             rSurname = Left(rSurname, 5)
    ElseIf iLength = 4 Then
        rSurname = rSurname & " "
    ElseIf iLength = 3 Then
        rSurname = rSurname & "  "
    ElseIf iLength = 2 Then
        rSurname = rSurname & "   "
    ElseIf iLength = 1 Then
        rSurname = rSurname & "    "
    Else
        rSurname = rSurname
End If


'Set Suffix value
nSuffix = 1
    Do
    'Combine Surname and suffix
    rOutput = rSurname & Format(nSuffix, "0000")
            'Check whether Output in list range
            sFindString = "rOutput"
            If Trim(FindString) <> "" Then
                With Sheets("Sheet1").Range("D:D")
                    Set Rng = .Find(What:=FindString, _
                                    After:=.Cells(.Cells.Count), _
                                    LookIn:=xlValues, _
                                    LookAt:=xlWhole, _
                                    SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False)
                If Not Rng Is Nothing Then
                 rOutput = rOutput
                Else
                    nSuffix = nSuffix + 1
                End If
            End With
        End If
        Loop

    'Add Outputs to Columns
    Range("B" + numrows).Value = rSurname
    Range("C" + numrows).Value = nSuffix 
    Range("D" + numrows).Value = rOutput

    Loop Until IsEmpty(rSurname)
End Sub

Answer 1

Вот гораздо более простая версия:

Sub CreateStrings()
    Dim rng As Range
    Dim i As Long, s As String
    Dim cl As Range
    Dim v

    Set rng = Range([A2], Me.[A2].End(xlDown))
    For Each cl In rng.Cells
        s = cl.Value
        If Len(s) < 5 Then
            s = s & Space(5 - Len(s))
        Else
            s = Left(s, 5)
        End If
        i = 1
        v = Application.Match(s & Format(i, "0000"), Me.[D:D], 0)
        Do While Not IsError(v)
            i = i + 1
            v = Application.Match(s & Format(i, "0000"), Me.[D:D], 0)
        Loop
        cl.Offset(, 3) = s & Format(i, "0000")
    Next
End Sub

Answer 2

, вероятно, лучше снять фильтр и использовать функцию листа, как

iFoundStrings = 
   Application.WorksheetFunction.CountIf(Sheets("Sheet1").Range("D:D"), 
   FindString)