Я оригінальний плакат. Приносимо вибачення за те, що ви не розмістили у відповідності до звичайної практики. Я знайшов деякий код, подібний до того, що мені було потрібно у відповіді на досить схожий запит. Я пристосував його до того, що мені було потрібно:
Sub MoreAndMoreSheets()
Dim ListSh As Worksheet, BaseSh As Worksheet
Dim NewSh As Worksheet
Dim ListOfNames As Range, LRow As Long, cell As Range
With ThisWorkbook
Set ListSh = .Sheets("List")
Set BaseSh = .Sheets("Base")
End With
LRow = ListSh.Cells(Rows.Count, "A").End(xlUp).Row '--Get last row of list.
Set ListOfNames = ListSh.Range("A6:A" & LRow) '--Qualify our list.
With Application
.ScreenUpdating = False '--Turn off flicker.
.Calculation = xlCalculationManual '--Turn off calculations.
End With
For Each cell In ListOfNames '--For every name in list...
BaseSh.Copy After:=Sheets(Sheets.Count) '--Copy Base sheet.
Set NewSh = ActiveSheet '--Let's name it NewSh.
With NewSh
On Error GoTo Boom '--In case of errors.
.Name = cell.Value '--Set the sheet's name to that of our current name in list.
GoTo LetUsContinue '--Skip to the LetUsContinue block.
Boom: '--In case of duplicate names...
.Name = "Dup" & cell.Value '--Add "Dup" to beginning.
.Tab.ColorIndex = 53 '--Change the tab color of the duplicate tab to orange for easy ID.
LetUsContinue:
On Error GoTo 0 '--Turn off error handling.
.Range("A1") = cell.Value
.Calculate '--Calculate page.
End With
Next cell
With Application
.ScreenUpdating = True '--Return to proper state.
.Calculation = xlCalculationAutomatic '--Return to automatic calculation.
End With
BaseSh.Activate '--Select Base.
MsgBox "Done!" '--Done!
End Sub
Я використав вікно перегляду з посиланням на аркуш списку в комірці B1 базового листа, який виконав те, що я хотів щодо другого стовпця, що проходить через:
= VLOOKUP (A1, "Список"! A6: B500,2, FALSE)
Завдяки TheLaughingMan, чи повинен він коли-небудь читати це, як його був код, який я адаптував.