Макрос с циклом по столбцам

[Елена195]

Добрый день!

Подскажите пожалуйста как можно оптимизировать макрос?
В файле есть таблица, по месяцу, необходимо ее преобразовать в список.
Я написала макрос, но он как я понимаю достаточно долгий и не оптимальный.
Что-то мне подсказывает, что это можно сделать быстрее и короче через цикл, но никак не могу понять как..
Это мое первое знакомство с макросами.

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

Буду очень благодарна)

[Aleksandr H.]

Option Explicit

Private Sub ScreensOFF()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual 'Это поможет при наличии завязанных на редактируемые данные формул
    Application.EnableCancelKey = xlDisabled ' Fix for Code execution has been interrupted
End Sub

Private Sub ScreensON()
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic 'Это поможет при наличии завязанных на редактируемые данные формул
End Sub

Sub GoMyWork()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim iLastRow As Integer
    Dim iLastCol As Integer
    Dim i, j, r
    Set sh1 = Sheets("Один ролик")
    Set sh2 = Sheets("c"): sh2.range("A2:H5000").ClearContents
    ScreensOFF
    With sh1
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        iLastCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
        r = 2
        For i = 4 To iLastRow
            For j = .Range("CD1").Column To iLastCol
                If .Cells(i, j) <> "" Then
                    r = r + 1
                    sh2.Cells(r, "A") = .Cells(3, j)
                    sh2.Cells(r, "B") = .Cells(i, "B")
                    sh2.Cells(r, "C") = .Cells(i, "C")
                    sh2.Cells(r, "D") = .Cells(i, "D")
                    sh2.Cells(r, "E") = .Cells(i, "E")
                    sh2.Cells(r, "F") = .Cells(i, "F")
                    sh2.Cells(r, "G") = .Cells(i, "G")
                    sh2.Cells(r, "H") = .Cells(i, j)
                End If
            Next j
        Next i
    End With
    ScreensON
    Set sh1 = Nothing
    Set sh2 = Nothing
End Sub

[Елена195]

Александр,

Большое спасибо!
Макрос работает просто прекрасно!

Пытаюсь понять как работает этот код. мои вопросы зеленым:

Option Explicit

Private Sub ScreensOFF() 'Это что бы было не видно как вставляются ячейки. верно? это ускоряет макрос?
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual 'Это что то вроде вставить значения?
    Application.EnableCancelKey = xlDisabled ' немного не поняла, что делает эта строка.
End Sub

Private Sub ScreensON()
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic 'Зачем это прописывать второй раз?
End Sub

Sub GoMyWork()
    Dim sh1 As Worksheet 
    Dim sh2 As Worksheet
    Dim iLastRow As Integer
    Dim iLastCol As Integer
    Dim i, j, r
    Set sh1 = Sheets("Один ролик")
    Set sh2 = Sheets("c"): sh2.range("A2:H5000").ClearContents 'Как я понимаю это очищает диапазон A2:H5000 от значений, а первая строка остается для заголовков, верно?
    ScreensOFF
    With sh1 
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row 'Тут задается что по столбцам нужно двигаться вверх, верно?
        iLastCol = .Cells(3, .Columns.Count).End(xlToLeft).Column 'Тут задается что по строкам нужно двигаться влево, верно, а с третьей потому что таблица интересующая нас начинается с третьей строки?
        r = 2
        For i = 4 To iLastRow
            For j = .Range("CD1").Column To iLastCol
                If .Cells(i, j) <> "" Then
                    r = r + 1
                    sh2.Cells(r, "A") = .Cells(3, j)
                    sh2.Cells(r, "B") = .Cells(i, "B")
                    sh2.Cells(r, "C") = .Cells(i, "C")
                    sh2.Cells(r, "D") = .Cells(i, "D")
                    sh2.Cells(r, "E") = .Cells(i, "E")
                    sh2.Cells(r, "F") = .Cells(i, "F")
                    sh2.Cells(r, "G") = .Cells(i, "G")
                    sh2.Cells(r, "H") = .Cells(i, j)
                End If
            Next j
        Next i
    End With 'Тут заканчивается работа с первым числом, и если мы хотим добавить так же данные из второго листа ( с такой же структурой), нам нужно:
Set sh3 = Sheets("Второй лист")
With sh3
        iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        iLastCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
        r = Cells(Rows.Count, 1).End(xlUp).Row
        For i = 4 To iLastRow
            For j = .Range("CD1").Column To iLastCol
                If .Cells(i, j) <> "" Then
                    r = r + 1
                    sh2.Cells(r, "A") = .Cells(3, j)
                    sh2.Cells(r, "B") = .Cells(i, "C")
                    sh2.Cells(r, "C") = .Cells(i, "D")
                    sh2.Cells(r, "D") = .Cells(i, "E")
                    sh2.Cells(r, "E") = .Cells(i, "F")
                    sh2.Cells(r, "F") = .Cells(i, "G")
                    sh2.Cells(r, "G") = .Cells(i, "H")
                    sh2.Cells(r, "H") = .Cells(i, j)
                End If
            Next j
        Next i
    End With  
    ScreensON
    Set sh1 = Nothing
    Set sh2 = Nothing
Set sh3 = Nothing ' Подскажите пожалуйста, зачем нужна эта строка? Это так бы закрытие действия если по заданным условиям не осталось данных?

End Sub

Буду благодарна за ответы)

[Aleksandr H.]

Private Sub ScreensOFF() 
' http://www.codernotes.ru/articles/vba/uskorit-vypolnenie-vba.html
End Sub

Private Sub ScreensON()
' http://www.codernotes.ru/articles/vba/uskorit-vypolnenie-vba.html
End Sub

Sub GoMyWork()
    Set sh2 = Sheets("c"): sh2.range("A2:H5000").ClearContents ' очистить диапазон А2:Н5000 листа С
    
	iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row 'Найти номер последней строки с данными на листе "Один ролик". Искать по столбце В
    iLastCol = .Cells(3, .Columns.Count).End(xlToLeft).Column 'Найти номер последнего столбца с данными в 3 строке на лсите "Один ролик"
        
    End With 'Тут заканчивается работа с листом "Один ролик"
	
	'если мы хотим добавить так же данные из второго листа ( с такой же структурой), нам нужно:
	set sh1 = Sheets("Второй лист")
	With sh1 
        .....
    End With 
    
	Set sh3 = Nothing ' Не нужна
End Sub

[Елена195]

Александр, то есть мы как бы переименовываем переменную?

Сообщение от Aleksandr H.

'если мы хотим добавить так же данные из второго листа ( с такой же структурой), нам нужно:
set sh1 = Sheets("Второй лист")
With sh1
.....

[p51x]

Что вы подразумеваете под переименованием? Если мы пишем а = 1. Мы единицу переименовываем?

[Елена195]

Нет,
если а=1, а потом а=2 то мы а переименовали из 1 в 2

[Aleksandr H.]

Нет, мы делаем переменную Sh1 ссылкой на обект Sheets("Второй лист")

https://docs.microsoft.com/ru-ru/off.../set-statement

Можете вместо sh1 использовать Sheets("Второй лист")

With sheets("Второй лист")
.....

тогда ненужны и

set sh1 = sheets("Второй лист") i set sh1 = nothing

[Елена195]

Александр,

Спасибо большое.
Теперь вроде все поняла)