Нехитрое копирование диапозонов значений

[Vastennis]

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

[Hugo121]

Почему 3 диапазона?

Option Explicit

Function MyTransp(r As Range)
    Dim i&, ii&, x&, a()
    a = r.Value
    ReDim b(1 To (UBound(a, 1) - 1) * (UBound(a, 2) - 1), 1 To 3)
    For i = 2 To UBound(a, 2)
        For ii = 2 To UBound(a, 1)
            x = x + 1
            b(x, 1) = a(ii, 1)
            b(x, 2) = a(1, i)
            b(x, 3) = a(ii, i)
        Next
    Next
    MyTransp = b
End Function

Код в стандартный модуль, выделяете диапазон для результата (можно с запасом), вводите в строке формул как формулу массива =MyTransp(A2:E6)
Можно затем спецвставкой заменить формулу на полученные значения, лишние #Н/Д удалить.
Столбцу с датами вручную задать нужный формат!

[Скрипт]

Sub Procedure_1()

    Dim rTopHeader As Excel.Range
    Dim rLeftHeader As Excel.Range
    Dim rData As Excel.Range
    Dim lRowsCount As Long
    Dim lStart As Long
    Dim i As Long
    
    'Даём имя диапазону с заголовками, которые сверху от данных.
    Set rTopHeader = Range("B2:E2")
    
    'Даём имя диапазону с заголовками, которые слева от данных.
    Set rLeftHeader = Range("A3:A6")
    
    'Даём имя диапазону, из которого берём данные.
    Set rData = Range("B3:E6")

    'Узнаём сколько строк в диапазоне с данными.
    lRowsCount = rData.Rows.Count
    
    'Задаём строку, с которой нужно вставлять данные.
    lStart = 3
    
    'Делаем цикл столько раз, сколько столбцов с данными.
    For i = 1 To rData.Columns.Count Step 1
    
        Cells(lStart, "H").Resize(lRowsCount, 1).Value = rLeftHeader.Value
        Cells(lStart, "I").Resize(lRowsCount, 1).Value = rTopHeader.Cells(1, i).Value
        Cells(lStart, "J").Resize(lRowsCount, 1).Value = rData.Columns(i).Value
        lStart = lStart + lRowsCount
        
    Next i

End Sub

[Vastennis]

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

Почему 3 диапазона?

Option Explicit

Function MyTransp(r As Range)
    Dim i&, ii&, x&, a()
    a = r.Value
    ReDim b(1 To (UBound(a, 1) - 1) * (UBound(a, 2) - 1), 1 To 3)
    For i = 2 To UBound(a, 2)
        For ii = 2 To UBound(a, 1)
            x = x + 1
            b(x, 1) = a(ii, 1)
            b(x, 2) = a(1, i)
            b(x, 3) = a(ii, i)
        Next
    Next
    MyTransp = b
End Function

Код в стандартный модуль, выделяете диапазон для результата (можно с запасом), вводите в строке формул как формулу массива =MyTransp(A2:E6)
Можно затем спецвставкой заменить формулу на полученные значения, лишние #Н/Д удалить.
Столбцу с датами вручную задать нужный формат!

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

[Hugo121]

Ну хорошо, 3:

Option Explicit

Function MyTransp(vsh As Range, gsh As Range, dannie As Range)
    Dim i&, ii&, x&, a()
    a = dannie.Value
    ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 3)
    For i = 1 To UBound(a, 2)
        For ii = 1 To UBound(a, 1)
            x = x + 1
            b(x, 1) = vsh(ii)
            b(x, 2) = gsh(i)
            b(x, 3) = a(ii, i)
        Next
    Next
    MyTransp = b
End Function

На листе
=MyTransp(A3:A6;B2:E2;B3:E6) (в весь диапазон, формула массива!)

[Vastennis]

Сообщение от Скрипт

Sub Procedure_1()

    Dim rTopHeader As Excel.Range
    Dim rLeftHeader As Excel.Range
    Dim rData As Excel.Range
    Dim lRowsCount As Long
    Dim lStart As Long
    Dim i As Long
    
    'Даём имя диапазону с заголовками, которые сверху от данных.
    Set rTopHeader = Range("B2:E2")
    
    'Даём имя диапазону с заголовками, которые слева от данных.
    Set rLeftHeader = Range("A3:A6")
    
    'Даём имя диапазону, из которого берём данные.
    Set rData = Range("B3:E6")

    'Узнаём сколько строк в диапазоне с данными.
    lRowsCount = rData.Rows.Count
    
    'Задаём строку, с которой нужно вставлять данные.
    lStart = 3
    
    'Делаем цикл столько раз, сколько столбцов с данными.
    For i = 1 To rData.Columns.Count Step 1
    
        Cells(lStart, "H").Resize(lRowsCount, 1).Value = rLeftHeader.Value
        Cells(lStart, "I").Resize(lRowsCount, 1).Value = rTopHeader.Cells(1, i).Value
        Cells(lStart, "J").Resize(lRowsCount, 1).Value = rData.Columns(i).Value
        lStart = lStart + lRowsCount
        
    Next i

End Sub

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

[DiemonStar]

Вариант решения формулами: