Макрос на копирование диапазона ячеек со смещением и транспонированием по 2 ячейки

@Nerealist · Регистрация: 15.05.2014

Author24 — интернет-сервис помощи студентам

Есть код, который необходимо интерпретировать.
Суть его работы сейчас в том что он заходит в каждую книгу в папке(28-31 в зависимости от месяца) и копирует оттуда данные.

Есть массив данных строки и столбцы
В Строку данные за месяц от первого столбца наименования.

Объясняю:
A1 наименование
B1-Z1 данные за месяц

Необходимо:

Наименование поставить в ячейку A1, после чего второе наименование будет скопировано на тот диапазон, на котором закончится перестановка данных с первой строки. Т.е. предположим A31.

Данные за месяц переставить из строчки в столбец по 2 ячейки.
B2-C2 в B2-С2 , E2-F2 в B3-C3 и т.д. в другом листе

Сделать это заходя в каждую книгу месяца и брать оттуда информацию за две ячейки получается, но работает долго и только по одному наименованию. т.е. приходится руками переставлять диапазон и опять запускать макрос по всем 31 книгам.

Переделать у меня самостоятельно не получилось, прошу помощи.

Макрос полусамопал с гуглом, так что прошу прощения.

Visual Basic

Sub EMS_TRY()
ActWbMonth = ActiveWorkbook.Name
'BookMonth = InputBox("Какой месяц?(ря)", "Вопрос")
'BookDay = InputBox("До какого числа?", "Вопрос")
Dim s As String, fldr As String
With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        fldr = .SelectedItems(1)
End With
 
fldr = fldr & IIf(Right(fldr, 1) = Application.PathSeparator, "", Application.PathSeparator)
Filename$ = Dir(fldr & "*.xlsm")
Application.ScreenUpdating = False
Dim noi As String
noi = 0
Do While Filename$ <> ""
    With Workbooks.Open(fldr & Filename$)
        'действия с книгой
        '.Close
        'MsgBox "Это " & Filename$
        'Application.Run "'" & Filename$ & "'!Module34.EMS" Запуск макроса из другой книги
        Dim DTO As Integer
        Dim ActWb As String
        ActWb = ActiveWorkbook.Name 'Записываем активную книгу чтобы вернуться к ней
        DTO = DTO + 2
        'DTO = InputBox("За какое число отчёт?", "Вопрос")
        'DTO = DatePart("d", Now)Бывшая схема работы с датой по выборке даты.
        Sheets("ЛистZ").Select
        '1.1
        Range("C2:D49").Select 'То что необходимо исправить.!!!!!!!!!!!!!
        Selection.Copy
        Windows(ActWbMonth).Activate '
        Sheets("Лист4").Select
        Cells(5, 2 + DTO).Select 'Выбор даты на листе отчёта
        ActiveSheet.Paste
        
        
    Application.CutCopyMode = False
        Windows(ActWb).Activate 'Возвращаемся к уже неактивной книге
        Workbooks(ActWb).Close SaveChanges:=False
    End With
    Filename$ = Dir
    If noi = 30 Then
      Exit Do
    End If
    noi = noi + 1
Loop
Application.ScreenUpdating = True
End Sub

	26.01.2021, 22:45