Цитирование через столбцы и создание рабочих листов, ошибка 1004

Question

У меня есть исходный файл «Categories_by_Year.xlsm», где у меня есть листы на каждый год между 2010 и 2014 годами, содержащие разные категории и данные (по одной категории на столбец). Я хочу, чтобы каждый год создавалась новая рабочая книга, а каждая категория сохранялась как новый лист в файле. Первая строка каждого столбца - это имя категории, которое используется для новых имен рабочих листов. От строки 2 до последней не пустой строки - данные копируются и затем переносятся на новый рабочий лист.

Когда я запускаю следующий код, создается файл и первый лист (первый столбец копируется и переносится в новый файл). Однако после этого я получил ошибку времени выполнения «1004». Я попытался начать с разных столбцов, и он по-прежнему бросает сообщение об ошибке после создания первого.

Sub NewShForEachCategory() 
Dim LastRow As Double 

For year = 2010 To 2014 

     Workbooks.Add 
     ActiveWorkbook.SaveAs Filename:="C:\" & CStr(year) & ".xls", FileFormat:=xlExcel8 

     Workbooks("Categories_by_Year.xlsm").Activate 

For col = 1 To 35 

    If Not IsEmpty(Workbooks("Categories_by_Year.xlsm").Worksheets(CStr(year)).Cells(1, col)) Then 

    Category = Workbooks("Categories_by_Year.xlsm").Worksheets(CStr(year)).Cells(1, col).Value 
    LastRow = Workbooks("Categories_by_Year.xlsm").Worksheets(CStr(year)).Cells(Rows.Count, col).End(xlUp).Row 

    Workbooks("Categories_by_Year.xlsm").Worksheets(CStr(year)).Range(Cells(2, col), Cells(LastRow, col)).Copy 
    Workbooks(CStr(year) & ".xls").Activate 
    Workbooks(CStr(year) & ".xls").Worksheets.Add.Name = Category 
    Workbooks(CStr(year) & ".xls").Worksheets(Category).Cells(1, 1).PasteSpecial Transpose:=True 
    End If 

Next col 

Next year 

End Sub 

Answer 1

Непроверенные:

Sub NewShForEachCategory() 

Dim wbCBY as Workbook, wbY as Workbook, Category 
Dim sht as Worksheet, year as Long, col as Long 

    Set wbCBY = Workbooks("Categories_by_Year.xlsm") 

    For year = 2010 To 2014 

     Set wbY = Workbooks.Add() 
     wbY.SaveAs Filename:="C:\" & CStr(year) & ".xls", _ 
        FileFormat:=xlExcel8 

     Set sht = wbCBY.Worksheets(CStr(year)) 

     For col = 1 To 35 

      Category = Trim(sht.Cells(1, col).Value) 

      If Len(Category) > 0 Then 

       sht.Range(sht.Cells(2, col), _ 
         sht.Cells(sht.Rows.Count, col).End(xlUp)).Copy 

       With wbY.Worksheets.Add() 
       .Name = Category 
       .Cells(1, 1).PasteSpecial Transpose:=True 
       End With 

      End If 

     Next col 

    Next year 

End Sub