Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Перемещение листов в книге, Перемещение листов согласно их имени
 
#1
18.05.2022 10:02:23
Добрый день!
Подскажите, как можно реализовать в VBA анализ листов книги и отсортировать их исходя из имени листов?
А именно на примере файла во вложении: имеем книгу с листами ОП-010, ОП-015, ОП-030, КН-010, КН-015, КН-030, ВО-1, ВО-2
Нужно вызовом макроса расставить листы в таком порядке: ВО-1, ВО-2, КН-010, ОП-010, КН-015, ОП-015, КН-030, ОП-030
Т.е. листы КН должны быть перед листами ОП согласно их номеру 010 перед 010
 
 
 
#2
18.05.2022 11:04:43
Код
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
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#3
20.05.2022 15:20:05
Ігор Гончаренко, Попробовал запустить Ваш код, выдает ошибку, не могу понять почему
 
 
 
#4
20.05.2022 15:27:15
Код
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
 
 
 
#5
20.05.2022 16:04:56
выложите файл, в котором не работает, посмотрю
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
Страницы: 1
Наверх