L oop дальше не идет

Question

Я довольно плохо знаком с VBA и программированием в целом. Вот что я пытаюсь сделать:

У меня есть база данных, начинающаяся со строки 21 моего листа (с сохранением имени, имени, работы). Я пытаюсь использовать для l oop, чтобы создать новый лист для каждого имени в базе данных - например (1 - Уильям), (2 - Джон) ...

Когда мы добавляем новый член нашей базы данных и запуск нашего макроса. Он должен добавить новый лист (но не изменять ничего из существующих), поэтому с другими словами просто пропустите (1 - Уильям) и (2 - Джон), но добавьте (3 - Кера).

Пока что создаются 2 первых рабочих листа, но когда я добавляю кого-то в свою базу данных - новый рабочий лист не добавляется.

Может ли кто-нибудь из вас, эксперты, помочь мне решить эту проблему и затормозить то, что я делаю неправильно?

Sub test()
Dim i As Long, LastRow As Long
LastRow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row

Dim blnFound As Boolean
blnFound = False

For i = 21 To LastRow

For x = 1 To Worksheets.Count
    If Worksheets(x).Name = ((i -21) + 1) & " - " & Worksheets("Database").Cells(i, 3).Value Then
        blnFound = True
    End If
Next

    If blnFound = False Then
        Worksheets.Add.Move After:=Sheets(1)
        ActiveSheet.Name = ((i - 21) + 1) & " - " & Worksheets("Database").Cells(i, 3).Value
    End If

Next i


End Sub

Answer 1

Надеюсь, вам это поможет:

Sub CreateNewSheetFromRange()

    Dim mySht As Worksheet
    Dim mySheet As Worksheet
    Dim BeginRow As Long
    Dim myStr As String

    Dim r As New Collection
    Dim Pos As Integer
    On Error Resume Next
    For a = 1 To Sheets.Count

        'To List Your Sheet With Name Begin With Number & " - "
        'If you don't care how many time time the same value repeat,
        'you can disobey this for loop
        Pos = InStr(Sheets(a).Name, " - ")
        If Pos > 0 Then
           r.Add Sheets(a).Name, Mid(Sheets(a).Name, Pos + 3)
        End If
        On Error GoTo 0

    Next


    BeginRow = 21

    Do While True
       On Error Resume Next
       myStr = ((BeginRow - 21) + 1) & " - " & Worksheets("Data").Cells(BeginRow, 3).Value

       If Worksheets("Data").Cells(BeginRow, 3).Value = "" Then
          Exit Do
       End If

       'If you hope avoid your repeated cells value to create new sheet
       'perform this
       myVal = r.Item(Worksheets("Data").Cells(BeginRow, 3).Value)
       'If you don't care about repeated value, you change this with:
       'set mySht=worksheets(myStr)

       If Err.Description <> "" Then
          On Error GoTo 0
          Set mySheet = Sheets.Add(After:=Sheets(Sheets.Count))
          'If you don't care about repeated value, remove this r.add
           r.Add myStr, Worksheets("Data").Cells(BeginRow, 3).Value
          mySheet.Name = myStr
          a = 1
       End If

       BeginRow = BeginRow + 1
    Loop
End Sub