VBA代码-根据列表中的项目命名图纸，同时确保图纸不重复_Vba_Excel_Excel 2010

VBA代码-根据列表中的项目命名图纸，同时确保图纸不重复

vba excel

VBA代码-根据列表中的项目命名图纸，同时确保图纸不重复,vba,excel,excel-2010,Vba,Excel,Excel 2010,我很困惑。我有一份工作手册，作为登记册，用作部分业务的模板。用户建立一个他们正在跟踪的注册表项列表。对于主登记册中的每个项目，我需要创建一个工作表，提供有关问题的更多详细信息。新工作表是工作簿“TemplateCRA”中模板的副本。在登记表“所有权”中创建或更新了所有ENTREI后，使用单个宏完成创建操作我从这一点开始，这一点很有效： Sub Button1_Click() ' ' Button1_Click Macro ' Dim MyCell As Range, MyRange A

我很困惑。我有一份工作手册，作为登记册，用作部分业务的模板。用户建立一个他们正在跟踪的注册表项列表。对于主登记册中的每个项目，我需要创建一个工作表，提供有关问题的更多详细信息。新工作表是工作簿“TemplateCRA”中模板的副本。在登记表“所有权”中创建或更新了所有ENTREI后，使用单个宏完成创建操作

我从这一点开始，这一点很有效：

Sub Button1_Click()
'
' Button1_Click Macro
'
    Dim MyCell As Range, MyRange As Range

        Set MyRange = Sheets("Ownership").Range("B11:B30")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))

    For Each MyCell In MyRange
        If IsEmpty(MyCell) Then End
        Sheets("TemplateCRA").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
        Sheets(Sheets.Count).Name = "CRA Ref " & MyCell.Value ' renames the new worksheet
        Range("B6").Value = ActiveSheet.Name

    Next MyCell
End Sub

然后，我继续进行此操作，以确保宏首先检查是否已为已注册项目创建工作表，如果已创建工作表，则会提醒用户，然后继续循环项目列表并创建所需的新工作表

Sub Button2_Click()
    '
    ' Button2_Click Macro
    '
    Dim MyCell As Range, MyRange As Range
    Dim sh As Worksheet, flg As Boolean
    Set MyRange = Sheets("Ownership").Range("B11:B30")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))
    For Each MyCell In MyRange
            If IsEmpty(MyCell) Then End

            For Each sh In Worksheets
                If sh.Name Like "CRA Ref " & MyCell.Value Then flg = True: Exit For
            Next
            If flg = True Then
                MsgBox sh.Name & " Found!"
            ElseIf flg = False Then
                MsgBox "Creating CRA Ref " & MyCell.Value & " now!"
                Sheets("TemplateCRA").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
                Sheets(Sheets.Count).Name = "CRA Ref " & MyCell.Value ' renames the new worksheet
                Range("B6").Value = ActiveSheet.Name
            End If

    Next MyCell
    MsgBox "You may now complete your CRA for each item"
End Sub

但这并不能正常工作。似乎发生的情况是：

sh.Name检查循环通过OK报告找到工作表，直到找到没有工作表的项目为止

运行时错误91-未设置块变量的对象变量

在第一行MsgBox中

有人能告诉我我做错了什么吗

干杯

问题是您没有在外部for循环中初始化您的

flg

。因此，对于第二个循环，

flg

的默认值为TRUE，它在每个

循环的内部中循环，并且找不到sh，sh-->空-->运行时错误

修复您的代码：
Sub Button2_Click()
    '
    ' Button2_Click Macro
    '
    Dim MyCell As Range, MyRange As Range
    Dim sh As Worksheet, flg As Boolean
    Set MyRange = Sheets("Ownership").Range("B11:B30")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))
    For Each MyCell In MyRange
            If IsEmpty(MyCell) Then
               exit for
            end if
            flg = False ' init the flg each time
            For Each sh In Worksheets
                'Changed Like --> = to ensure the worksheet exists
                If sh.Name = "CRA Ref " & MyCell.Value Then
                    flg = True
                    Exit For
                End If
            Next
            If flg = True Then
                MsgBox sh.Name & " Found!"
            ElseIf flg = False Then
                MsgBox "Creating CRA Ref " & MyCell.Value & " now!"
                Sheets("TemplateCRA").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
                Sheets(Sheets.Count).Name = "CRA Ref " & MyCell.Value ' renames the new worksheet
                Range("B6").Value = ActiveSheet.Name
            End If

    Next MyCell
    MsgBox "You may now complete your CRA for each item"
End Sub

问题是您没有在外部for循环中初始化flg。
因此，对于第二个循环，flg
的默认值为TRUE，它在每个循环的内部中循环，并且找不到sh，sh-->空-->运行时错误

修复您的代码：
Sub Button2_Click()
    '
    ' Button2_Click Macro
    '
    Dim MyCell As Range, MyRange As Range
    Dim sh As Worksheet, flg As Boolean
    Set MyRange = Sheets("Ownership").Range("B11:B30")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))
    For Each MyCell In MyRange
            If IsEmpty(MyCell) Then
               exit for
            end if
            flg = False ' init the flg each time
            For Each sh In Worksheets
                'Changed Like --> = to ensure the worksheet exists
                If sh.Name = "CRA Ref " & MyCell.Value Then
                    flg = True
                    Exit For
                End If
            Next
            If flg = True Then
                MsgBox sh.Name & " Found!"
            ElseIf flg = False Then
                MsgBox "Creating CRA Ref " & MyCell.Value & " now!"
                Sheets("TemplateCRA").Copy After:=Sheets(Sheets.Count) 'creates a new worksheet
                Sheets(Sheets.Count).Name = "CRA Ref " & MyCell.Value ' renames the new worksheet
                Range("B6").Value = ActiveSheet.Name
            End If

    Next MyCell
    MsgBox "You may now complete your CRA for each item"
End Sub

四件事
请避免使用End
。看到这个了吗
使用xlDown
查找最后一行可能非常危险。看看@brettdj是如何解释的
有关如何获取最后一行，请参见此
您可以仅在几行中检查图纸是否存在。不需要在工作表中循环
我还没有测试代码，但它应该可以工作。如果你有任何错误，只要让我知道哪一行是给你的错误，我们将采取从那里
Sub Button1_Click()
    Dim ws As Worksheet, wsTemp As Worksheet
    Dim MyCell As Range, MyRange As Range
    Dim LRow As Long

    Set ws = ThisWorkbook.Sheets("Ownership")

    With ws
        LRow = .Range("B" & .Rows.Count).End(xlUp).Row

        Set MyRange = .Range("B11:B" & LRow)

        For Each MyCell In MyRange
            If Len(Trim(MyCell.Value)) <> 0 Then
                On Error Resume Next
                Set wsTemp = ThisWorkbook.Sheets("CRA Ref " & MyCell.Value)
                On Error GoTo 0

                If wsTemp Is Nothing Then '<~~ Sheet doesn't exists
                    ThisWorkbook.Sheets("TemplateCRA").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
                    ThisWorkbook.Sheets(Sheets.Count).Name = "CRA Ref " & MyCell.Value
                Else '<~~ Sheet exists
                    MsgBox "sheet exists"
                End If

                set wsTemp = nothing

            End If
        Next MyCell
    End With
End Sub

子按钮1\u单击（）
将ws作为工作表，将wsTemp作为工作表
Dim MyCell作为范围，MyRange作为范围
暗淡的光线和长的一样
设置ws=ThisWorkbook.Sheets（“所有权”）
与ws
LRow=.Range（“B”和.Rows.Count）.End（xlUp）.Row
设置MyRange=.Range（“B11:B”和LRow）
对于MyRange中的每个MyCell
如果Len（Trim（MyCell.Value））为0，则
出错时继续下一步
设置wsTemp=ThisWorkbook.Sheets（“CRA Ref”和MyCell.Value）
错误转到0
如果wsTemp什么都不是，那么有四件事
请避免使用End
。看到这个了吗
使用xlDown
查找最后一行可能非常危险。看看@brettdj是如何解释的
有关如何获取最后一行，请参见此
您可以仅在几行中检查图纸是否存在。不需要在工作表中循环
我还没有测试代码，但它应该可以工作。如果你有任何错误，只要让我知道哪一行是给你的错误，我们将采取从那里
Sub Button1_Click()
    Dim ws As Worksheet, wsTemp As Worksheet
    Dim MyCell As Range, MyRange As Range
    Dim LRow As Long

    Set ws = ThisWorkbook.Sheets("Ownership")

    With ws
        LRow = .Range("B" & .Rows.Count).End(xlUp).Row

        Set MyRange = .Range("B11:B" & LRow)

        For Each MyCell In MyRange
            If Len(Trim(MyCell.Value)) <> 0 Then
                On Error Resume Next
                Set wsTemp = ThisWorkbook.Sheets("CRA Ref " & MyCell.Value)
                On Error GoTo 0

                If wsTemp Is Nothing Then '<~~ Sheet doesn't exists
                    ThisWorkbook.Sheets("TemplateCRA").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
                    ThisWorkbook.Sheets(Sheets.Count).Name = "CRA Ref " & MyCell.Value
                Else '<~~ Sheet exists
                    MsgBox "sheet exists"
                End If

                set wsTemp = nothing

            End If
        Next MyCell
    End With
End Sub

子按钮1\u单击（）
将ws作为工作表，将wsTemp作为工作表
Dim MyCell作为范围，MyRange作为范围
暗淡的光线和长的一样
设置ws=ThisWorkbook.Sheets（“所有权”）
与ws
LRow=.Range（“B”和.Rows.Count）.End（xlUp）.Row
设置MyRange=.Range（“B11:B”和LRow）
对于MyRange中的每个MyCell
如果Len（Trim（MyCell.Value））为0，则
出错时继续下一步
设置wsTemp=ThisWorkbook.Sheets（“CRA Ref”和MyCell.Value）
错误转到0
如果wsTemp什么都不是，那么“我在自己的代码中从不使用“END”，它是从OP的帖子继承的。谢谢你的阅读，我现在要改了@Siddharthrout当然，我只是指出问题所在，懒得重新考虑代码。非常感谢-两个答案都有效-我将合并这两个答案的赌注，现在可以看到我的错误。我在自己的代码中从不使用“结束”，它是从OP的帖子继承而来的。谢谢你的阅读，我现在要改了@悉达多当然，我只是指出问题所在，太懒了，无法重新考虑代码。非常感谢-两个答案都有效-我将合并这两个答案的赌注，现在可以看到我的错误。非常感谢-两个答案都有效-我将合并这两个赌注，现在可以看到我的错误。非常感谢-两个答案都有效-我将合并这两个赌注，现在可以看到我的错误。