Копирование нескольких диапазонов в нескольких выборках

Question

У меня есть словарь диапазонов (groupRange), в котором мне нужно подтолкнуть содержимое каждой ячейки в этих диапазонах влево.

Простым решением было бы зацикливание словаря следующим образом:

Вариант 1 - Слишком медленно

For Each x In groupRange
    Range(groupRange(x)).Copy Destination:=Range(groupRange(x)).Offset(0, -1)
Next x

Количество диапазонов варьируется, но обычно это происходит достаточно медленно, чтобы вызывать серьезные проблемы.

Я пытался Union, но быстро понял, что копирование и вставка нескольких выделенных элементов, подобных этому, не нравится Excel.

Вариант 2 - не работает

Set r = Range(groupRange("G1"))
For Each x In groupRange
    Set r = Union(r, Range(groupRange(x)))
Next x
r.Copy Destination:=r.Offset(0, -1)

Это просто оставляет меня с ошибкой «не может использоваться при множественном выборе».

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

ВАРИАНТ 3 - Лучшее, что у меня есть

 Range("AF5:CY51").Copy Range("AE5")

Технически это работает, поскольку все между ними пусто (по крайней мере, на данный момент) но я бы хотел избежать манипулирования клетками, которые я не использую.

Мне нужно переместить по крайней мере значение и цвет ячеек.

Любые предложения о том, как решить эту проблему?

Мне нужно выполнить это действие еще раз в l oop, по крайней мере, один раз в секунду. И мне нужно увидеть изменения между каждым l oop, так как это будет представлять данные в режиме реального времени.

Уточнение

Считайте, что это будет весь код, с подпунктом printer(), который мне нужен;

Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
Public Const GrpAmount As Integer = 24

Public Function groupRange() As Scripting.Dictionary
    Static dict As Dictionary
    Dim i As Long
    If dict Is Nothing Then
        Set dict = New Scripting.Dictionary
        For i = 1 To GrpAmount
            dict.add "G" & i, "AF" & i * 2 + 3 & ":CY" & i * 2 + 3
        Next i
    End If
    Set groupRange = dict
End Function

Sub TimerLoop()
Dim i As Long
For i = 0 To 20
    Call printer
    Sleep 100
Next i
End Sub

Public Sub printer()
Dim x As Variant, r As Range
'Option 1
For Each x In groupRange
   Range(groupRange(x)).Copy Destination:=Range(groupRange(x)).Offset(0, -1)
Next x
'Option 3
Range("AF5:CY51").Copy Range("AE5")

End Sub

Answer 1

Я бы попробовал что-то вроде этого:

Public Sub printer()

    Dim x As Variant, r As Range, d
    Application.Screenupdating = False
    Application.Calculation = xlCalculationManual
    Set d = groupRange  'See Scott's comment above
    For Each x In d
       with Range(d(x))
          .Copy Destination:=.Offset(0, -1)
       End With
    Next x
    Application.Screenupdating = True
    Application.Calculation = xlCalculationAutomatic
    DoEvents 'catch up
End Sub

Суть в том, что Excel не является отличной анимационной платформой.