生成對應於行值的工作表（存在重複值）

Question

我有一個主工作表（Install_Input），其中工作表編號，測試部分和材料由用戶手動輸入。

（下圖：範圍A1：：Install_Input WS的圖示C8）

表＃| TestSection |材料

..... 1 ..... | .......... A .......... | .STEEL。|

..... 2 ..... | .......... B .......... | .PLASTIC。|

..... 3 ..... | .......... C .......... | .STEEL。|

..... 5 ..... | .......... G .......... | .STEEL。|

..... 2 ..... | .......... F .......... | .PLASTIC。|

..... 2 ..... | .......... A .......... | .STEEL。|

..... 5 ..... | .......... D .......... | .PLASTIC。|

我想在當前工作簿中生成與在Install_Input中輸入的工作表編號相對應的工作表。我所做的代碼將爲MyRange中的每個值生成一個新表格，但是，我希望我的代碼跳過生成已存在的表格。我嘗試使用「On Error Resume Next」和「On Error GoTo 0」命令來解決這個問題，但他們只是生成了未命名的工作表來補償那些已經存在的工作表。

Sub Consolidate_Sheets() 
    Dim MyCell As Range 
    Dim MyRange As Range 
    Dim ws As Worksheet 

    Set MyRange = Sheets("Install_Input").Range("A2") 
    Set MyRange = Range(MyRange, MyRange.End(xlDown)) 


    For Each MyCell In MyRange 
     If Sheets(Sheets.Count).Name <> MyCell.Value Then 
      'On Error Resume Next 
      Sheets.Add After:=Sheets(Sheets.Count) 
      Sheets(Sheets.Count).Name = MyCell.Value 
      'On Error GoTo 0 
     End If 
    Next MyCell 
End Sub 

Answer 1

您可以使用以下兩種功能：

Function getSheetWithDefault(name As String, Optional wb As Excel.Workbook) As Excel.Worksheet 
     If wb Is Nothing Then 
      Set wb = ThisWorkbook 
     End If 

     If Not sheetExists(name, wb) Then 
      wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).name = name 
     End If 

     Set getSheetWithDefault = wb.Sheets(name) 
    End Function 

    Function sheetExists(name As String, Optional wb As Excel.Workbook) As Boolean 
     Dim sheet As Excel.Worksheet 

     If wb Is Nothing Then 
      Set wb = ThisWorkbook 
     End If 

     sheetExists = False 
     For Each sheet In wb.Worksheets 
      If sheet.name = name Then 
       sheetExists = True 
       Exit Function 
      End If 
     Next sheet 
    End Function 

要在代碼中使用它：

Sub Consolidate_Sheets() 
     Dim MyCell As Range 
     Dim MyRange As Range 
     Dim ws As Worksheet 

     Set MyRange = Sheets("Install_Input").Range("A2") 
     Set MyRange = Range(MyRange, MyRange.End(xlDown)) 

     For Each MyCell In MyRange 
      If Sheets(Sheets.Count).Name <> MyCell.Value Then 
       'On Error Resume Next 
       set ws = getSheetWithDefault(MyCell.Value) 
       'On Error GoTo 0 
      End If 
     Next MyCell 
    End Sub 

Answer 2

您可以實現一個CheckSheet函數像this SO answer描述的，通過所有現有的片材循環並比較傳入的值中的每個片材的名稱。