Question

我有以下问题：我有500行和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开始。有人可以建议如何完成它，我想这几乎已经完成但我缺少“新”表的字符串此外，现在我得到错误，说我当然不能有两张同名的床单。感谢

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

excel如果为true则创建新工作表

1 个答案: