Запустить макрос на основе ответа в ячейке

Question

Могу ли я написать макрос, где - командная кнопка проверит таблицу (аналогичную приведенной ниже) для ответов Да в столбце A

Например,

Столбец A
Ответы

• Да
• Нет
• NA
• Да
• Да

Название столбца B соответствующей вкладки

• Вкладка - 001
• Вкладка - 002
• Вкладка - 003
• Вкладка - 004
• Tab - 005

Если ответ «Да», то он должен - запустить «CopysheetandRename» и назвать вкладку в соответствии с именем вкладки в столбце B - макрос ниже, как я понимаю, мне придетсяудалите поле ввода и каким-то образом замените его на загар в столбце B (т. е. «Tab - 001») в циклической функции.Однако я не уверен, как это можно сделать.

Public Sub CopySheetAndRename()
Dim newName As String

On Error Resume Next
newName = InputBox("Enter the name for the copied worksheet")

If newName <> "" Then
    ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    On Error Resume Next
    ActiveSheet.Name = newName
    Range("$D$3").Value = newName
End If

Dim n As Name
For Each n In ActiveWorkbook.Names
n.Visible = True
Next n

Dim numrow
numrow = Range("F16").Value

If IsNumeric(numrow) Then

For i = 1 To numrow

Call INRW

Next i

End If

End Sub'

В конечном итоге я пытаюсь достичь командной кнопки, которая поможет мне с помощью Tab-001, Tab-004, Tab-005 черезкомандная кнопка и использование существующего макроса «Copysheetandrename»

Надеюсь, что это имеет смысл и извините за длинный вопрос

Редактировать:

Я загрузил оригинал xlsmв приведенной ниже ссылке на диске Google:
[Ссылка] https://drive.google.com/open?id=1fpgqlyDN72OC6S9NOh_MTh5Ur4ZKWz46 В этом файле «Ответы» находятся в столбце O, а название соответствующей вкладки - в столбце C. Кнопка «Copysheetandrename» находится вШаблон 'tab

Answer 1

Попробуйте этот код:

Private Sub CommandButton1_Click() 'Replace with your Command Button name
Dim i As Long, lastRow As Long

With Me
    lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To lastRow
        If .Cells(i, 1).Value2 = "Yes" Then Call CopySheetAndRename(.Cells(i, 2).Value2)
    Next i
End With

End Sub

Чтобы это работало, вам необходимо изменить существующую процедуру следующим образом:

Public Sub CopySheetAndRename(Optional newName As String = "")

On Error Resume Next
If newName = "" Then newName = InputBox("Enter the name for the copied worksheet")

If newName <> "" Then
    ActiveSheet.Copy After:=Worksheets(Sheets.Count)
    ActiveSheet.Name = newName
    ActiveSheet.Range("$D$3").Value = newName
End If

Dim n As Name
For Each n In ActiveWorkbook.Names
    n.Visible = True
Next n

Dim numrow
numrow = Range("F16").Value

If IsNumeric(numrow) Then

For i = 1 To numrow
    Call INRW
Next i

End If

End Sub

РЕДАКТИРОВАТЬ: Обновлено, чтобы соответствовать набору данных OP:

Private Sub CommandButton1_Click() 'Replace with your Command Button name
    Dim i As Long, lastRow As Long

    With Me
        lastRow = .Cells(Rows.Count, 15).End(xlUp).Row
        For i = 1 To lastRow
            If .Cells(i, 15).Value2 = "Yes" Then Call CopySheetAndRename(.Cells(i, 3).Value2)
        Next i
    End With

    End Sub