尝试根据数据创建新的工作簿

Question

尝试根据数据创建新的工作簿。适用于一组数据，但不适用于更多数据。我分别测试了22-和11-，它可以工作，但不能一起工作。 llllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllll

Dim rw As Long, lastrow As Long, MySel As Range 'Grabs skus and moves to new sheet

With Worksheets("Sheet1")
    For rw = 1000 To 2 Step -1
        If .Cells(rw, 8).Value Like "*22-*" Then
            If MySel Is Nothing Then
                Set MySel = .Cells(rw, 1).EntireRow

                    Else
                        Set MySel = Union(MySel, .Cells(rw, 1).EntireRow)



                    Dim sWorkbook As Workbook

                     'Create New Workbook
                    Set sWorkbook = Workbooks.Add

                     'Save Above Created New Workbook
                     sWorkbook.SaveAs Filename:="C:\CODE\22 Production.xlsx"


                    End If
                End If
            Next rw
        End With

With Workbooks("22 Production").Worksheets("Sheet1")
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
    If Not MySel Is Nothing Then
        MySel.Copy Destination:=.Cells(lastrow + 1, 1)
        'MySel.Delete
    End If
End With

Dim rw1 As Long, lastrow1 As Long, mysel1 As Range 'Grabs skus and moves to new sheet

With Worksheets("Sheet1")
    For rw1 = 1000 To 2 Step -1
        If .Cells(rw1, 8).Value Like "*11-*" Then
            If mysel1 Is Nothing Then
                Set mysel1 = .Cells(rw1, 1).EntireRow

                    Else
                        Set mysel1 = Union(mysel1, .Cells(rw1, 1).EntireRow)



                    Dim sWorkbook1 As Workbook

                     'Create New Workbook
                    Set sWorkbook1 = Workbooks.Add

                     'Save Above Created New Workbook
                     sWorkbook1.SaveAs Filename:="C:\CODE\11 Production.xlsx"


                    End If
                End If
            Next rw1
        End With

With Workbooks("11 Production").Worksheets("Sheet1")
    lastrow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
    If Not mysel1 Is Nothing Then
        mysel1.Copy Destination:=.Cells(lastrow1 + 1, 1)
        'mysel1.Delete
    End If
End With

下标超出范围