Код для расщепления рабочего листа на несколько листов

Question

Код для разделения рабочего листа на несколько листов. Но, вот в чем проблема. Когда я его запускаю. Это дает мне чистые листы и не помещает данные в эти листы.

Вот код:

Sub parse_data() 
    Dim lr As Long 
    Dim ws As Worksheet 
    Dim vcol, i As Integer 
    Dim icol As Long 
    Dim myarr As Variant 
    Dim title As String 
    Dim titlerow As Integer 
    vcol = 2 
    Set ws = Sheets("AdHocReport_course (2)") 
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row 
    title = "A1:Y1" 
    titlerow = ws.Range(title).Cells(1).Row 
    icol = ws.Columns.Count 
    ws.Cells(1, icol) = "Unique" 
    For i = 2 To lr 
     On Error Resume Next 
     If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then 
      ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol) 
     End If 
    Next 
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants)) 
    ws.Columns(icol).Clear 
    For i = 2 To UBound(myarr) 
     ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "" 
     If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 
      Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & "" 
     Else 
      Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count) 
     End If 
     ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1") 
     Sheets(myarr(i) & "").Columns.AutoFit 
    Next 
    ws.AutoFilterMode = False 
    ws.Activate 
End Sub 

Answer 1

Трудно сказать, если это ваша проблема, но:

If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 

Если вы используете по умолчанию Application.Evaluate форма Evaluate, то он будет оценивать формулу в контексте из Активного листа: было бы безопаснее использовать форму листа:

If Not ws.Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then 

тогда он будет использовать ws как контекст.