Перебор несмежных листов книги

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Перебор несмежных листов книги (Макросы/Sub)

vzdorny

Дата: Четверг, 08.08.2019, 19:37 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 21

Репутация: 0 ±

Замечаний: 0% ±

Excel 2003

Здравствуйте!
У меня есть однотипный код, который обрабатывает
первый и четвёртый листы в книге, перекрашивая ячейки в них
[vba]

Код

Dim x As Range
Dim s As String
s = Лист1.Name
    For Each x In ThisWorkbook.Worksheets(s).UsedRange
        If x.Interior.Color = vbRed Or x.Interior.Color = vbGreen Then x.Interior.Color = vbBlue
    Next
s = Лист4.Name
    For Each x In ThisWorkbook.Worksheets(s).UsedRange
        If x.Interior.Color = vbRed Or x.Interior.Color = vbGreen Then x.Interior.Color = vbBlue
    Next

[/vba]
Но что делать если мне нужно обрабатывать каждый третий лист, а их будет допустим 40?
Неужели необходимо плодить однотипные записи?
И желательно обращаться к листам по кодовому имени на случай если пользователь
решит их переименовать или переместить
То есть по здесь идее нужен цикл с шагом 3 от 1 до Workbooks(1).Sheets.Count
но работающий код мне написать не удалось, постоянно какие-то ошибки возникают

Есть идеи, как это реализовать?
Спасибо!

Ответить

nilem

Дата: Четверг, 08.08.2019, 20:30 | Сообщение № 2

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

vzdorny, привет
типа такого пойдет?
[vba]

Код

Sub ttt()
Dim i&
With ThisWorkbook
    For i = 1 To .Sheets.Count Step 3
        MsgBox .Sheets(i).Name
    Next i
End With
End Sub

[/vba]

Яндекс.Деньги 4100159601573

Ответить

vzdorny

Дата: Четверг, 08.08.2019, 22:01 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 21

Репутация: 0 ±

Замечаний: 0% ±

Excel 2003

nilem, не совсем.
если я правильно понимаю, то в данном случае
обращение к листу происходит по его порядковому номеру,
который меняется, если его перетащить
(например, если в новой книге, состоящей из листов,
ярлычки которых расположены слева направо [Лист1, Лист2 и т.д.]
поменять местами ярлычки Лист1 и Лист2,
то Лист2 станет первым, а Лист1 вторым)

Сообщение отредактировал vzdorny - Четверг, 08.08.2019, 22:05

Ответить

InExSu

Дата: Пятница, 09.08.2019, 00:08 | Сообщение № 4

Группа: Друзья

Ранг: Ветеран

Сообщений: 648

Репутация: 96 ±

Замечаний: 0% ±

Excel 2010, 365

Привет!

Цитата vzdorny, 08.08.2019 в 22:01, в сообщении № 3 ()

обращение к листу происходит по его порядковому номеру,
который меняется, если его перетащить

Нет. Не меняется.

Разработчик Битрикс24 php, Google Apps Script, VBA Excel Windows/Mac

Ответить

boa

Дата: Пятница, 09.08.2019, 08:42 | Сообщение № 5

Группа: Друзья

Ранг: Ветеран

Сообщений: 559

Репутация: 167 ±

Замечаний: 0% ±

365

Цитата InExSu, 09.08.2019 в 00:08, в сообщении № 4 ()

Нет. Не меняется.

Меняется
[vba]

Код

Sub test()
Dim sh As Worksheet

For Each sh In Worksheets
    Debug.Print sh.Name; sh.Index
Next

    Sheets(2).Move Before:=Sheets(1)

For Each sh In Worksheets
    Debug.Print sh.Name; sh.Index
Next

End Sub

[/vba]

Сообщение отредактировал boa - Пятница, 09.08.2019, 08:48

Ответить

_Boroda_

Дата: Пятница, 09.08.2019, 10:14 | Сообщение № 6

Группа: Админы

Ранг: Местный житель

Сообщений: 16718

Репутация: 6505 ±

Замечаний: ±

2003; 2007; 2010; 2013 RUS

Такой вариант (с учетом того, что кодовые имена не переименовывались)
[vba]

Код

Sub tt()
    scn_ = Sheets(1).CodeName
    For i = 1 To Len(scn_)
        If IsNumeric(Mid(scn_, i, 1)) Then
            tcn_ = Left(scn_, i - 1)
            Exit For
        End If
    Next i
    For i = 1 To Sheets.Count
        If Replace(Sheets(i).CodeName, tcn_, "") Mod 3 = 1 Then
            For Each x_ In Sheets(i).UsedRange
                With x_
                    ic_ = .Interior.Color
                    If ic_ = vbRed Or ic_ = vbGreen Then
                        .Interior.Color = vbBlue
                    End If
                End With
            Next
        End If
    Next i
    MsgBox "Всё"
End Sub

[/vba]

* Немного переписал и файл перевложил

К сообщению приложен файл: 186852_1.xlsm (23.8 Kb)

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995