Question

我有2张表--Entry＆amp;主。我想x没有带有宏的Master副本。如果在条目表A1中有值 - 1副本 A1＆amp; A2有价值 - 2份 A1＆amp; A2＆amp; A3有价值 - 3份...... 同样最多5份如果A1：A5选择

每个复制的工作表名称应为A1到A5的值

Sub CopyMaster()
ThisWorkbook.Worksheets("Master").Visible = xlSheetVisible
If ThisWorkbook.Worksheets(Worksheets("Entry").Range("A1").Value) Then
    MsgBox ("Cannot Copy.. Please Check Your Selection")
Else
    Worksheets("Master").Copy After:=Worksheets(Sheets.Count)
    ActiveSheet1.Name = Worksheets("Entry").Range("A1").Value
    ActiveSheet2.Name = Worksheets("Entry").Range("A2").Value
    MsgBox ("Successfully created.... x Copies")
    ThisWorkbook.Worksheets("Master").Visible = xlSheetVeryHidden
End If
End Sub

Answer 1

<强>编辑：

添加了新的工作表重命名
添加了可能的工作表名称重复处理

可能就是你所追求的：

Option Explicit

Sub CopyMaster()
    Dim cell As Range
    Dim nSheets As Long

    With Selection '<--| reference selection
        If .Parent.Parent.Name = ThisWorkbook.Name Then '<--| check for referenced (selected) cells to be in the proper workbook
            If .Parent.Name = "Entry" Then '<--| '<--| check for referenced (selected) cells to be in the proper worksheet
                If Not Intersect(.Cells, .Parent.Columns(1)) Is Nothing Then '<--| check for referenced (selected) cells to be in column "A"
                    For Each cell In Selection.SpecialCells(xlCellTypeConstants) '<--| loop through referenced (selected) non blank cells
                        If Not existentWorksheet(cell.value) Then '<--| if no sheets with current cell name already ...
                            Worksheets("Master").Copy After:=Worksheets(Sheets.Count) '<--| ... make a new copy of master workbook
                            ActiveSheet.Name = cell.value '<--| rename it
                            nSheets = nSheets + 1 '<--| update copied worksheets counter
                        Else
                            MsgBox "worksheet '" & cell.value & " already in " ' & ThisWorkbook.Name, vbCritical + vbOKOnly
                        End If
                    Next cell
                    If nSheets > 0 Then MsgBox "Successfully created " & nSheets & IIf(nSheets > 1, " copies", "copy"), vbInformation + vbOKOnly
                End If
            End If
        End If
    End With
End Sub

Function existentWorksheet(shtName As String) As Boolean
    On Error Resume Next
    existentWorksheet = Worksheets(shtName).Name = shtName
End Function

Answer 2

这是一个复制工作表的示例函数，请注意我如何使用类型化变量来处理几乎所有内容。一旦功能变得复杂，它会让您的生活更轻松。另请参阅用于导入字典数组对象的参考库。

我将其留给您处理隐藏的工作表问题，因为它可能会影响worksheets.count的使用。

Option Explicit
' Tools/References
' [x]Microsoft Scripting Runtime

Public Sub CopyMaster()
    Dim wb As Workbook
    Dim wsCurrent As Worksheet
    Dim wsMaster As Worksheet
    Dim wsEntry As Worksheet
    Dim wsNew As Worksheet
    Dim arrNames As Scripting.Dictionary
    Dim idx As Long
    Dim copied As Long
    Dim sName As String

    Set wb = ActiveWorkbook
    Set wsCurrent = wb.ActiveSheet
    Set wsMaster = wb.Worksheets("Master")
    Set wsEntry = wb.Worksheets("Entry")
    Set arrNames = New Scripting.Dictionary

    ' check for conflict worksheet names first
    For idx = 1 To 5
        sName = Trim(wsEntry.Cells(1, idx))
        If (sName <> "") Then
            If isWorksheet(wb, sName) Or arrNames.Exists(sName) Then
                Call MsgBox("Worksheet name " & sName & " conflict")
                Exit Sub
            End If
            Call arrNames.Add(sName, "")
        End If
    Next

    ' copy worksheets
    copied = 0
    For idx = 1 To 5
        sName = Trim(wsEntry.Cells(1, idx))
        If (sName = "") Then GoTo ContinueLoop
        wsMaster.Copy after:=wb.Worksheets(wb.Worksheets.Count)
        Set wsNew = wb.ActiveSheet  ''Set wsNew = wb.Worksheets(wb.Worksheets.Count)
        wsNew.Name = sName
        copied = copied + 1

ContinueLoop:
        ' next step
    Next
    wsCurrent.Activate
    Call MsgBox("Created " & copied & " copies")
End Sub

Private Function isWorksheet(wb As Workbook, sName As String) As Boolean
    On Error Resume Next
    isWorksheet = False
    isWorksheet = Not wb.Worksheets(sName) Is Nothing
    On Error GoTo 0
End Function

编辑添加了Scripting.Dictionary来处理元组名称。

Answer 3

如果[Entry!A1:A5]中的单元格值重复或具有相同名称的工作表，则不会添加新的工作表。如果出现上述任一情况，则会突出显示包含错误值的单元格，并显示一条显示错误值的消息。如果所有值都有效，则会显示一条消息，显示已创建的工作表数。

Sub CopyMaster()
    Application.ScreenUpdating = False
    Dim rEntries As Range, r As Range
    Dim ws As Worksheet
    Dim msg As String
    Dim list(1) As Object
    Set list(0) = CreateObject("System.Collections.ArrayList")
    Set list(1) = CreateObject("System.Collections.ArrayList")

    Worksheets("Master").Visible = xlSheetVisible
    For Each ws In Worksheets
        list(0).Add ws.Name
    Next

    Set rEntries = Worksheets("Entry").Range("A1:A5")
    For Each r In rEntries
        If r.Text <> "" Then
            If list(0).Contains(r.Text) Or list(1).Contains(r.Text) Then

                msg = msg & r.Value & vbCrLf
                r.Interior.ColorIndex = 6
            Else
                list(1).Add r.Text
                r.Interior.Color = -4142
            End If
        End If
    Next

    If Len(msg) Then
        MsgBox "Cannot Copy.. Please Check Your Selection" & vbCrLf & msg, vbInformation, "Try Again"
        GoTo EnableScreenUpdating
    End If

    For Each r In rEntries
        If r.Text <> "" Then
            Worksheets("Master").Copy After:=Worksheets(Sheets.Count)
            ActiveSheet.Name = r.Text
        End If
    Next

    MsgBox ("Successfully created.... " & WorksheetFunction.CountA(rEntries) & "  Copies")

EnableScreenUpdating:
    Worksheets("Master").Visible = xlSheetVeryHidden
    Application.ScreenUpdating = True

End Sub

Excel VBA - 具有不同名称的工作表的多个副本

3 个答案: