excel创建新工作表如果为true

Question

我有以下问题：我有5000行和50列的excel表。我需要复制和粘贴表单并将第一个表中的行中的特定单元格的值导出到此表单中，但如果B1和B2中的值相同，则不要创建另一个表单，而要将其复制到第一行中的同一表单上。我添加了条件“07”，因为我不希望excel在一个过程中创建5000张。到目前为止我有这个：

Sub Button1_Click() 
Dim newsheetname As String 
Dim isometry As String 
Application.ScreenUpdating = False 
Worksheets("Sheet1").Activate 
x = 2 

Do While Cells(x, 4) <> "" 

If Cells(x, 1) = "07" Then 
Sheets(Sheets.Count).Select 
Cells(33, 2) = Sheet1.Cells(x, 4)  
Cells(33, 28) = Sheet1.Cells(x, 32) 
End If 

If Cells(x, 4) <> Cells(x + 1, 4) Then 
Sheets("template").Copy After:=Sheets(Sheets.Count) 
ActiveSheet.Name = isometry 
End If 

isometry = Sheet1.Cells(x + 1, 4) 
x = x + 1 
Worksheets("Sheet1").Activate 

Loop 

End Sub 

我知道我的“代码”很简单，并不完美，我从VBA开始。可以有人建议如何完成它，我想这几乎完成，但我缺少“新”表 字符串，现在我得到错误说，我不能有2张相同的名称，当然。 感谢

Answer 1

Sub Button1_Click() 
    Dim newsheetname As String 
    Dim isometry As String 
    Dim newSheet As Worksheet 
    Application.ScreenUpdating = False 
    x = 2 

    'Go down the Sheet1 until we find a blank cell in column 4 
    Do While Worksheets("Sheet1").Cells(x, 4) <> "" 

     'If we find the value 07, copy two values to the isometry sheet 
     If Sheet1.Cells(x, 1) = "07" Then 

      isometry = Sheet1.Cells(x, 4) 

      'create the sheet if it does not exist 
      If Not SheetExists(isometry) Then 
       Sheets("template").Copy After:=Sheets(Sheets.Count) 
       Sheets(Sheets.Count).Name = isometry 
      End If 

      'Copy our data 
      Sheets(isometry).Cells(33, 2) = Sheet1.Cells(x, 4) 
      Sheets(isometry).Cells(33, 28) = Sheet1.Cells(x, 32) 
     End If 

     'Move on to the next row 
     x = x + 1 

    Loop 
    Application.ScreenUpdating = True 
End Sub 

Function SheetExists(isometry) As Boolean 
    Dim exists As Boolean 
    exists = False 
    For Each Sheet In Worksheets 
     If Sheet.Name = isometry Then 
      exists = True 
      Exit For 
     End If 
    Next 
    SheetExists = exists 
End Function