Моя цель - иметь два листа в качестве источников и дублировать один из них. В Master Sheet есть список имен для листов и ячейка на листе, а в Hidden есть шаблон, который должен быть реплицирован для каждой копии.
У меня есть код на двух листах: «thisworkbook» и 2 модуля.
Моя проблема: VBA в Excel Переименование мастер-листа при копировании листа шаблона, а не именование скопированных листов после списка имен. Обратите внимание - это работало, когда у меня было 10 имен, но как только я уменьшил или увеличил его, код не удался.
Модуль 1
Sub Create_sheets()
Dim masterSheet As Worksheet
Dim hiddenSheet As Worksheet
Dim NewSheet As Worksheet
Dim myBook As Workbook
Dim lastRow As Long
Dim i As Long
Dim namesColumn
'Define your workbook - here set as the active workbook, assuming it contains masterSheet and hiddenSheet
Set myBook = ActiveWorkbook
'Define your worksheets - The sheets are named "Master Sheet" and "Template" respectively
Set masterSheet = myBook.Worksheets("Master Sheet")
Set hiddenSheet = myBook.Worksheets("Hidden")
'Define which column in your master tab the list is - here it's A i.e. column 1
''namesColumn = 1 or
namesColumn = 1
'Find the last row of the sheets list
lastRow = masterSheet.Cells(masterSheet.Rows.Count, "A").End(xlUp).Row
'Cycle through the list - Assuming the list starts in column "A" from the 2nd row
' 'For i = 2 To lastRow
For i = 2 To lastRow
With myBook
ActiveWorkbook.Sheets("Hidden").Visible = True
Application.ActiveWorkbook.Sheets("Hidden").Copy _
Before:=Application.ActiveWorkbook.Sheets("Hidden")
On Error Resume Next
'Find name of the tab and naming the tab
tabName = masterSheet.Cells(i, namesColumn)
If Err.Number = 1004 Then
Debug.Print cell.Value & " already used as a sheet name"
End If
On Error GoTo 0
End With
ActiveWindow.DisplayGridlines = False
' 'ActiveSheet.Cells(i, 1).Value = tabName
ActiveSheet.Name = tabName
Next i
'delete form control button
ActiveSheet.Buttons.Delete
ActiveWorkbook.Sheets("Hidden").Visible = False
End Sub
Function WorkSheetName() As String
ActiveSheet.Activate
WorkSheetName = ActiveSheet.Name
End Function
Sub update_formula()
Range("B1").Select
ActiveCell.FormulaR1C1 = "=WorkSheetName()"
Application.Selection.Calculate
End Sub
Модуль 2
Sub LastCell_In_Sheet ()
Dim LastCell As String
Dim rng As Range
Set rng = ActiveSheet.Cells
' Find the last cell
LastCell = Last(3,rng)
' Select the last cell in Rng
With rng.Parent
.Select
Range(LastCell, LastCell).Select
End With
End Sub
Function Last (choice As Long, rng As Range)
'last cell in a sheet
Dim lrw As Long
Dim lcol As Long
On Error Resume Next
lrw = rng.Find(What:="'", _
after:=rng.Cells(1), _
LookAt:=x1Part, _
LookIn:=x1Formulas, _
SearchOrder:=x1ByRows, _
SearchDirection:=x1Previous, _
MatchCase:=False).Row
On Error GoTo 0
On Error Resume Next
lcol = rng.Find(What:="'", _
after:=rng.Cells(1), _
LookAt:=x1Part, _
LookIn:=xlFormulas, _
SearchOrder:=x1ByColumns, _
SearchDirection:=x1Previous, _
MatchCase:=False).Column
On Error GoTo 0
On Error Resume Next
Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Nu=ber > 0 Then
Last = rng.Cells(l).Address(False, False)
Err.Clear
End If
On Error GoTo 0
End Function
Лист1 («Основной лист» - список имен листов)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Target, Range("a5:a25")) Is Nothing Then
Dim strName As String
strName = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
On Error Resume Next
Sheets(strName).Select
Call LastCell_In_Sheet
End If
End Sub
Лист 2 («Скрытый» лист - содержит шаблон, который необходимо скопировать для каждого имени в «Основном листе», а также ячейку). , B1, который имеет то же имя)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Target, Range("a1:f1")) Is Nothing Then
Dim strName As String
strName = ActiveCell.Value
Sheets("Master Sheet").Select
ActiveSheet.Range("C5").Select
End If
'put the autofilter back on if it has been removed.
If ActiveSheet.AutoFilterMode = False Then Rows(4).AutoFilter
'error handle the showalldata part
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Private Sub Worksheet_Activate()
Call update_formula
End Sub
ThisWorkbook
Private Sub Workbook_Open()
Worksheets("Master Sheet").Select
ActiveSheet.Range("C5").Select
'put the autofilter back on if it has been removed.
If ActiveSheet.AutoFilterMode = False Then Rows(4).AutoFilter
'error handle the showalldata part
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub