将数据复制到不同的命名多个工作表中

Question

亲爱的，

我是一个初学者，并尝试准备宏，该宏首先允许根据条件删除行，而不是根据第一个主工作表中的条件创建新工作表并将第一个主工作表中的数据添加到多个命名工作表中。

• 根据条件删除行（运行正常）
• 根据第一个主工作表的标准创建新工作表（运行正常）
• 从第一个主表添加数据（恒定范围 I4:I6） 到所有的 A1:A3 中的多个命名表（由该宏创建）。不幸的是，我不知道该怎么做:-(

你能帮我吗？

Private Sub CommandButton1_Click()

   Dim lastrow As Long, x As Long
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    For x = lastrow To 1 Step -1
        If UCase(Cells(x, 3).Value) = "0" And _
        UCase(Cells(x, 6).Value) = "0" Then
        Rows(x).Delete
        End If
    Next

    lastcell = ThisWorkbook.Worksheets("Obratova predvaha").Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To lastcell

    With ThisWorkbook

    newname = ThisWorkbook.Worksheets("Obratova predvaha").Cells(i, 1).Value

    .Sheets.Add after:=.Sheets(.Sheets.Count)

    ActiveSheet.Name = newname

    End With

    Next

    ThisWorkbook.Worksheets("Obratova predvaha").Activate
    ThisWorkbook.Worksheets("Obratova predvaha").Cells(1, 1).Select

End Sub

Answer 1

不太确定你的描述，但你可以试试这个：

已编辑以添加工作表变量并通过隐含地将其假设为 ActiveSheet 来防止在新工作表添加和写入之间发生任何（可能的？）时间间隔错误行为：

Option Explicit

Private Sub CommandButton1_Click()
    Dim lastrow As Long, i As Long
    Dim newSheet As Worksheet

    With Worksheets("Obratova predvaha")
        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = lastrow To 1 Step -1
            If UCase(.Cells(i, 3).Value) = "0" And UCase(.Cells(i, 6).Value) = "0" Then .Rows(i).Delete
        Next

        lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To lastrow
            Set newSheet = Sheets.Add(after:=Sheets(Sheets.Count)) ' add a new sheet and hold its reference in newSheet  variable
            newSheet.Range("A1:A3").Value = .Range("I4:I6").Value ' copy referenced sheet I4:I6 values into newly added sheet cells A1:A3
            newSheet.Name = .Cells(i, 1).Value ' change the name of newly added sheet
        Next
    End With
End Sub