Sub macros()
    Dim arr(), i As Long, lr As Long, fed As String
    Dim wb As Object, sh As Object, kult$
    On Error Resume Next
  
    Set wb = ActiveWorkbook
    With Workbooks.Add(xlWBATWorksheet).Sheets(1)
        [a1:i1].Value = Split("федеральный округ,Область,название культуры,Сельскохозяйственные организации,из них: малые предприятия,хозяйства " + _
"населения,крестьянские (фермерские) хозяйства и индивидуальные предприниматели,хозяйста всех категорий 2008,хозяйста всех категорий 2007", ",")

        For Each sh In wb.Sheets
            kult = sh.[a1] & " " & sh.[a2]
            arr = sh.UsedRange.Value
            For i = 6 To UBound(arr)

                If InStr(UCase(arr(i, 1)), UCase("федер")) = 0 Then
                    lr = .Cells(.Rows.Count, 2).End(xlUp).Row
                    .Cells(lr + 1, 2) = arr(i, 1)
                    .Cells(lr + 1, 3) = kult
                    .Cells(lr + 1, 4) = arr(i, 2)
                    .Cells(lr + 1, 5) = arr(i, 3)
                    .Cells(lr + 1, 6) = arr(i, 4)
                    .Cells(lr + 1, 7) = arr(i, 5)
                    .Cells(lr + 1, 8) = arr(i, 6)
                    .Cells(lr + 1, 9) = arr(i, 7)
                    .Cells(lr + 1, 1) = fed
                Else
                    fed = arr(i, 1)
                End If

            Next
        Next
        .UsedRange.EntireColumn.AutoFit
    End With
 On Error GoTo 0
End Sub

Workbooks.Open Filename:= _
"O:\tab460.xlsm"
Application.Run "Книга1_!!!!!!!.xlsm!Module2.macros"