транспортировать

[evdss]

Добрый день! Есть таблица в которой с помощью функции произвожу транспонирование столбца в строку, пока значение равно, например, коду 105. Помогите, пожалуйста,с макросом чтобы это выполнить автоматически

[Serge_Bliznykov]

извините за занудство, Вы, скорее всего, имеете в виду
транспонирование

[IgorGO]

выполниет Copy2Row при активном листе с данными.
предполагается данные в колонках А и В
результаты будут выведены, начиная с колокни Д

Sub Copy2Row()
  Dim d, k, r As Long
  Columns(4).Resize(, 250).ClearContents
  Set d = DictRange(Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))):  k = d.keys
  Application.ScreenUpdating = False
  Cells(1, 4) = "kod": Cells(1, 5) = "zn1": Cells(1, 6) = "zn2": Cells(1, 7) = "zn3..."
  Cells(2, 4).Resize(UBound(k) + 1, 1) = WorksheetFunction.Transpose(k)
  For r = 0 To UBound(k)
    d(k(r)).Offset(0, 1).Copy:  Cells(2 + r, 5).PasteSpecial Transpose:=True
  Next
  Application.ScreenUpdating = True
End Sub


Function DictRange(rg As Range)
  Dim i As Long, a As Long, s As String, ar, d
  Set d = CreateObject("Scripting.Dictionary")
  For a = 1 To rg.Areas.Count
    If rg.Areas(a).Count = 1 Then ar(1, 1) = rg.Areas(a) Else ar = rg.Areas(a)
    For i = 1 To rg.Areas(a).Count
      If d.exists(ar(i, 1)) Then
        Set d(ar(i, 1)) = Application.Union(d(ar(i, 1)), rg.Areas(a).Cells(i))
      Else
        Set d(ar(i, 1)) = rg.Areas(a).Cells(i)
      End If
    Next
  Next
  Set DictRange = d
End Function