Страницы: 1
RSS
Перемещение листов в книге, Перемещение листов согласно их имени
 
Добрый день!
Подскажите, как можно реализовать в VBA анализ листов книги и отсортировать их исходя из имени листов?
А именно на примере файла во вложении: имеем книгу с листами ОП-010, ОП-015, ОП-030, КН-010, КН-015, КН-030, ВО-1, ВО-2
Нужно вызовом макроса расставить листы в таком порядке: ВО-1, ВО-2, КН-010, ОП-010, КН-015, ОП-015, КН-030, ОП-030
Т.е. листы КН должны быть перед листами ОП согласно их номеру 010 перед 010
 
Код
Sub Sortirovka_listov()
  Dim ws As Worksheet, rg As Range, n&, a, c&
  ReDim a(1 To 1)
  For Each ws In Worksheets
    n = n + 1: ReDim Preserve a(1 To n): a(n) = ws.Name
  Next
  With Worksheets(1)
    c = .UsedRange.Column + .UsedRange.Columns.Count
    Set rg = .Cells(1, c).Resize(n, 1): rg = WorksheetFunction.Transpose(a)
    .Sort.SortFields.Clear
    .Sort.SortFields.Add2 Key:=rg, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange rg: .Header = xlNo: .MatchCase = False
        .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    End With
  End With
  a = rg: rg.ClearContents
  For n = 1 To n - 1
    Worksheets(a(n, 1)).Move Before:=Worksheets(n)
  Next
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, Попробовал запустить Ваш код, выдает ошибку, не могу понять почему
 
Код
Sub Sortirovka_listov()
  Dim ws As Worksheet, rg As Range, n&, a, c&
  ReDim a(1 To 1)
  For Each ws In Worksheets
    n = n + 1: ReDim Preserve a(1 To n): a(n) = ws.Name
  Next
  With Worksheets(1)
    c = .UsedRange.Column + .UsedRange.Columns.Count
    Set rg = .Cells(1, c).Resize(n, 1): rg = WorksheetFunction.Transpose(a)
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=rg, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange rg: .Header = xlNo: .MatchCase = False
        .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    End With
  End With
  a = rg: rg.ClearContents
  For n = 1 To n - 1
    Worksheets(a(n, 1)).Move Before:=Worksheets(n)
  Next
End Sub

 
выложите файл, в котором не работает, посмотрю
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
Страницы: 1
Читают тему (гостей: 1)
Наверх