работа с диапазонами в vba

[shchnad]

Уважаемые умные люди! Помогите, пжл! В vba - я новичок., хотя уже что-то начинаю фурычить, однако, не могу придумать алгоритм для своей задачи.... Ломаю голову уже неделю. Скоро мозги задымятся. Может кто подскажет как сделать....

задача такая... Есть разные таблицы с данными. Ячейки первой строки этих таблиц различаются по цвету - серые и без заливки. В самом начале макроса задается количество столбцов, которое нужно передвигать вправо за секунду функцией ActiveWindow.SmallScroll ToRight. Сдвигаемые в каждую секунду столбцы должны в эту секунду выделяться. Однако, если попадаются столбцы, которые не имеют в первой строке заливки, то они должны входить в секундный сдвиг дополнительно и прибавляться к выделенному диапазону ...возможно плохо формулирую задачу, поэтому покажу на примере ...

пусть, например, есть таблица с 1-й строкой ( с - серый, х - нет заливки)
х с с х х с х с с х с с с х х х с с

если выбрать, например, сдвиг на 2 столбца в секунду, то сдвигаться по-секундно должно так:
х с с - х х с х с - с х с - с с - х х х с с
(то есть по 2 "с" в каждой секунде)

если выбрать, например, сдвиг на 3 столбца в секунду, то сдвигаться по-секундно должно так:
х с с х х с - х с с х с - с с х х х с - с
(то есть по 3 "с" в каждой секунде)

если у кого есть идеи, как это сделать?

подскажиет пжл, где ошибка... почему Do..Loop не берет

Dim n As Variant
Dim StartBeat As Range
Dim k As Long
Dim c As Range
Dim to_play As Range
Dim last As Range
Dim count As Long

Call TakeoffAll
ActiveWindow.Zoom = 90
Range("AB1").Select

Set StartBeat = Application.InputBox _
        (Prompt:="Click on a cell to start from!", _
        Title:="Start", _
        Default:=Selection.Address, _
        Type:=8)
            
Restart:
n = InputBox("Input a number of cells to move per second", "Speed", 1)
If n = "" Then
    Exit Sub
Else
    If IsNumeric(n) = False Then
        GoTo Restart
    Else
        If n <= 0 Then
            GoTo Restart
        End If
    End If
End If

Application.Wait Now + TimeSerial(0, 0, 3)

Set to_play = Range(ActiveCell, Cells(1, Cells.SpecialCells(xlLastCell).Columns))
Application.FindFormat.Interior.ColorIndex = True
Set c = to_play.Find(SearchFormat:=RGB(219, 219, 219))
Do While Not c Is Nothing
k = k + 1
last = c.Address
    If k = n Then
    Range(ActiveCell, Cells(57, last.Column)).Select
        If Selection.Borders(xlEdgeRight).LineStyle = xlNone Then
        Application.Wait Now + TimeSerial(0, 0, 5)
        StartBeat.Select
        Exit Sub
        End If
    count = Selection.Column.count
    ActiveWindow.SmallScroll ToRight:=(n + count)
    Application.Wait Now + TimeSerial(0, 0, 1)
    Set to_play = Range(Cells(1, last.Column + 1), Cells.SpecialCells(xlLastCell).Row)
    k = 0
    Set c = to_play.Find(After:=c, SearchFormat:=RGB(219, 219, 219))
Loop

StartBeat.Select
End Sub

_____
Код программы нужно выделять (форматировать) тегами [CODE][/CODE] (читать FAQ)
Модератор

[Serge_Bliznykov]

я вам вряд ли помогу (уж очень у Вас задача "хитрая" и специфичная),
да и я не уверен, что вообще полагаться на таймер в Excel - это вполне надёжно (Windows не является системой реального времени).

НО. Рекомендую прилагать к коду тестовый файлик, в котором этот код должен выполняться.

p.s. ну конкретно про LOOP ответ простой.
Вы банально неверно написали.

в VBA есть цикл

WHILE Условие 
   .... команды внутри цикла
WEND

есть цикл

DO
   .... команды внутри цикла
LOOP Условие

но у Вас и не тот и не тот вариант.

попробуйте заменить слово LOOP на Wend, убрать ненужное DO в операторе While и закрыть не закрытый if (добавить End If)
это позволит вашему макросу запуститься.
но не факт, что это обеспечит его корректную работу!

[Aleksandr H.]

Запись цикла вроде верна
https://www.tutorialspoint.com/vba/v...while_loop.htm
если не срабатывает то надо протрассировать и искать ошибку. Вангую что

Set c = to_play.Find(SearchFormat:=RGB(219, 219, 219))

со старта вертает Nothing или валится в error

[shchnad]

Спасибо за ответ

немного код переделала, но вы - правы, он не рабочий, выдает ошибку 1004

вот файл, в котором код должен выполняться..

[IgorGO]

shchnad,
сможете обьяснить, что должно происходить в файле - есть шанс получить рабочий код.
а вообще, для работы с диапазонами изучайте методы обьекта Range в обьектной моделе Excel

[shchnad]

спасибо за ответ....в первом сообщении я уже попыталась объяснить, что я пытаюсь кодом сделать...

перемещать таблицу со скоростью n столбов в секунду, ...если попадается столбец, у которого в первой строке отсутсвует заливка, то он должен также в эту секунуду смещаться...смещающаяся область должна выделяться

вот попыталась объяснить комментариями

Sub Macros_d()

Dim n As Variant
Dim StartBeat As Range
Dim k As Long
Dim c As Range
Dim to_play As Range
Dim last As Long
Dim count As Long

'избавление от меню, однако с присутствием скролл бар
Call TakeoffAll

'установка масштаба 90%
ActiveWindow.Zoom = 90

'выделение первой ячейки таблицы для подстановки ниже как дефолтовой
Range("AB1").Select

'задание окном начальной (стартовой) ячейки, от которой должно начаться выделение
Set StartBeat = Application.InputBox _
        (Prompt:="Click on a cell to start from!", _
        Title:="Start", _
        Default:=Selection.Address, _
        Type:=8)
        
' задание n - скорости смещения (количества смещающихся столбцов в секунду)
Restart:
n = InputBox("Input a number of cells to move per second", "Speed", 1)
     If n = "" Then
     Exit Sub
     Else
          If IsNumeric(n) = False Then
              GoTo Restart
          Else
               If n <= 0 Then
               GoTo Restart
               End If
          End If
    End If

'пауза 3 секунды
Application.Wait Now + TimeSerial(0, 0, 3)

'задание диапазона (вся первая строка) для поиска серой заливки
Set to_play = Range(Cells(1, ActiveCell.Column), Cells(1, Cells.SpecialCells(xlLastCell).Columns))

Do
'цикл поиска по серой заливке
Application.FindFormat.Interior.Color = RGB(219, 219, 219)
Set c = to_play.Find("*", SearchFormat:=True)
If Not c Is Nothing Then
     Do
     'в случае нахождения ячейки с серой заливкой срабатывает счетчик
      k = k + 1
     'запоминается адрес этой ячейки с серой заливкой (а точнее номер ее столбца)
     last = c.Column
     'поиск по заливке продолжается
     Set c = to_play.Find("*", After:=c, SearchFormat:=True)
     'пока значение k не достигает n,
     Loop While k <= n
End If

'как только k достигает n, так область (шириной в 57 строк) от начала поиска до ячейки с серой заливкой выделяется
Range(Cells(1, ActiveCell.Column), Cells(57, last)).Select

'если выделенная область не имеет границы справа, то макрос ждет 5 секунд и останавливается
'причем до остановки выделяется выбранная в самом начале окном ячейка (стартовая)
    If Selection.Borders(xlEdgeRight).LineStyle = xlNone Then
    Application.Wait Now + TimeSerial(0, 0, 5)
    StartBeat.Select
    Exit Sub
    End If

'если, граница справа выделенной области присутствует, то идет подсчет количества в ней столбцов
count = Selection.Column.count

'смещение таблицы на это количество столбцов
ActiveWindow.SmallScroll ToRight:=count

'пауза в 1 секунду
Application.Wait Now + TimeSerial(0, 0, 1)

' назначение нового диапазона поиска
Set to_play = Range(Cells(1, last + 1), Cells(1, Cells.SpecialCells(xlLastCell).Columns))

'обнуление счетчика
k = 0

Loop

'возвращение на стартовую ячейку
StartBeat.Select

End Sub

Sub ChangeInterface(Value As Boolean)
    With Application
        .ScreenUpdating = False
        .Caption = IIf(Value = True, Empty, "Tabulation")
        .DisplayStatusBar = Value: .DisplayFormulaBar = Value
        Dim iCommandBar As CommandBar
        For Each iCommandBar In .CommandBars
            iCommandBar.Enabled = Value
        Next
        With .ActiveWindow
            .Caption = IIf(Value = True, .Parent.Name, "")
            .DisplayHeadings = Value: .DisplayGridlines = Value
            .DisplayWorkbookTabs = Value
        End With
        .ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"", " & Value & ")"
        .ScreenUpdating = True
    End With
End Sub

Sub TakeoffAll()
    ChangeInterface False
End Sub

Sub RecoverAll()
    ChangeInterface True
End Sub

выдает ошибку 91....
не понимаю, что хочет

ошибка на строке
'как только k достигает n, так область (шириной в 57 строк) от начала поиска до ячейки с серой заливкой выделяется
Range(Cells(1, ActiveCell.Column), Cells(57, last.Column)).Select

[IgorGO]

Сообщение от shchnad

я уже попыталась объяснить, что я пытаюсь кодом сделат

попытайтесь еще раз, что бы кому -то стало понятно.
понимаете, Вы этим никому не делаете одолжения. Вы делаете более вероятным получение конкретного ответа на свой вопрос. или ничего можно не делать и так уже все обьяснили ждите пока Вам накидают ответов, один точнее другого.

не нужно Вашего кода и комментариев к нему. нужно словесное описание задачи короткое, но достаточное для ее понимания.

[Aleksandr H.]

Сообщение от shchnad

выдает ошибку 91....
не понимаю, что хочет

ошибка на строке
'как только k достигает n, так область (шириной в 57 строк) от начала поиска до ячейки с серой заливкой выделяется
Range(Cells(1, ActiveCell.Column), Cells(57, last.Column)).Select

Нету в вышеприведённом коде такой строки, потому и ругается что last переменная не инициализированная. F8 не стесняйтесь использовать, проверяйте каждую строку, сначала в голове уясните что должно быть на этом этапе, потом сделали шаг трассировки. Совпало? Гуд. Не совпало? Перепроверяем все переменные и активно юзаем стаковерфлоу.

[shchnad]

доброе утро!
словесное объяснение задачи:

есть таблица, которая должна постепенно смещаться влево, чтобы показывать на экране новые и новые столбцы, находящиеся правее. Скорость смещения таблицы - количество столбцов смещения в секунду должно задаваться пользователем. Во время смещения количество смещаемых столбцов должно выделяться (к примеру, если пользователь задал скорость - три столбца, то должны выделиться на секунду одни три столбца, затем следующие в таблице правее три столбца и т.д. Столбец таблицы, от которого начинать выделение, также должен задаваться пользователем вначале. Когда таблица заканчивается, макрос должен остановиться, предварительно вернув таблицу в начальное состояние, то есть на выбранный пользователем стартовый столбец. Задача усложняется тем, что в первой строке таблицы ячейки имеют разную заливку (серую и без заливки). Столбцы, у которых ячейки первой строки не имеют заливки, должны входить в зону выделения дополнительно и также смещаться в ту же секунду, что и столбцы с серой заливкой. То есть область выделения в секунду может быть разной в зависимости от заливки в первой строке, однако ее первый столбец будет находиться на экране всегда в одном и том же месте (потому что смещаться будет то, количество столбцов, которое выделено), в области выделения количество столбцов с серой заливкой в первой строке будет всегда то, которое задал пользователь вначале.

[Aleksandr H.]

вот код который двигает
Только имхо "поиск серой заливки" не так делается, но вам виднее что подразумевается под "цикл поиска по серой заливке"

Sub Macros_d()
    
    Dim n As Variant
    Dim StartBeat As Range
    Dim k As Long
    Dim c As Range
    Dim to_play As Range
    Dim last As Long
    Dim count As Long
    
    'избавление от меню, однако с присутствием скролл бар
    Call TakeoffAll
    
    'установка масштаба 90%
    ActiveWindow.Zoom = 90
    
    'выделение первой ячейки таблицы для подстановки ниже как дефолтовой
    Range("AB1").Select
    
    'задание окном начальной (стартовой) ячейки, от которой должно начаться выделение
    Set StartBeat = Application.InputBox _
    (Prompt:="Click on a cell to start from!", _
    Title:="Start", _
    Default:=Selection.Address, _
    Type:=8)
    
    ' задание n - скорости смещения (количества смещающихся столбцов в секунду)
Restart:
    n = InputBox("Input a number of cells to move per second", "Speed", 1)
    If n = "" Then
        Exit Sub
    Else
        If IsNumeric(n) = False Then
            GoTo Restart
        Else
            n = CInt(n)
            If n <= 0 Then
                GoTo Restart
            End If
        End If
    End If
    
    'пауза 3 секунды
    Application.Wait Now + TimeSerial(0, 0, 3)
    
    'задание диапазона (вся первая строка) для поиска серой заливки
    Dim ilastcolumn As Integer
    ilastcolumn = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.count - 1
    Set to_play = Range(Cells(1, ActiveCell.Column), Cells(1, ilastcolumn))
    
    Do
        'цикл поиска по серой заливке
        Application.FindFormat.Interior.Color = RGB(219, 219, 219)
        Set c = to_play.Find("*", SearchFormat:=True)
        If Not c Is Nothing Then
            Do
                'в случае нахождения ячейки с серой заливкой срабатывает счетчик
                k = k + 1
                'запоминается адрес этой ячейки с серой заливкой (а точнее номер ее столбца)
                last = c.Column
                'поиск по заливке продолжается
                Set c = to_play.Find("*", After:=c, SearchFormat:=True)
                Debug.Print c.Address
                'пока значение k не достигает n,
            Loop While k <= n * 1
            'как только k достигает n, так область (шириной в 57 строк) от начала поиска до ячейки с серой заливкой выделяется
            Range(Cells(1, ActiveCell.Column), Cells(57, last)).Select
            
            'если выделенная область не имеет границы справа, то макрос ждет 5 секунд и останавливается
            'причем до остановки выделяется выбранная в самом начале окном ячейка (стартовая)
            If Selection.Borders(xlEdgeRight).LineStyle = xlNone Then
                Application.Wait Now + TimeSerial(0, 0, 5)
                StartBeat.Select
                Exit Sub
            End If
            
            'если, граница справа выделенной области присутствует, то идет подсчет количества в ней столбцов
            count = Selection.Columns.count
            
            'смещение таблицы на это количество столбцов
            ActiveWindow.SmallScroll ToRight:=count
            
            'пауза в 1 секунду
            Application.Wait Now + TimeSerial(0, 0, 1)
            
            ' назначение нового диапазона поиска
            Set to_play = Range(Cells(1, last + 1), Cells(1, last + ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.count))
            
            'обнуление счетчика
            k = 0
            
        Else
            Exit Do
        End If
    Loop
    
    'возвращение на стартовую ячейку
    StartBeat.Select
    
End Sub