Скопируйте данные в разные именованные несколько листов

Question

Уважаемые,

Я новичок и пытался подготовить макрос, который позволяет сначала удалять строки на основе условия, затем создавать новые листы на основе критериев из первого основного листа и добавлять данные из первого основного листана несколько именованных листов.

• удаляет строки на основе условия (RUNs OK)
• создает новые листы на основе критериев из первого основного листа (RUNs OK)
• добавляет данные из первого основного листа (постоянный диапазон 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