Требуется транспонировать столбцы разной высоты в примере выделены красным шрифтом ,в строчки напротив артикулов (выделены желтой заливкой) с условием что номера 5029,5030 и т.д. подстанавливаются в столбцы с аналогичными номерами. Артикулов обычно т 3000 и более ,а вариантов высоты столбцов от 1 до 7 (5029,5030,5031,5032,5033,5039,5042)
Sub trans()
Dim i As Long, lr As Long, i2 As Long, k As Long
Dim cell As Range
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 2).End(xlUp).Row
For i = lr To 2 Step -1
If Cells(i, 1) = "" Then
k = k + 1
Else
On Error Resume Next
For i2 = i + k To i Step -1
Set cell = Rows(1).Find(Cells(i2, 2))
Cells(i, cell.Column) = Cells(i2, 2)
Next i2
k = 0
End If
Next i
Application.ScreenUpdating = True
End Sub
Sub iTransp()
Dim iLastRow As Long
Dim Rng As Range
iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
For Each Rng In Range("B3:B" & iLastRow).SpecialCells(2, 1).Areas
Rng.Cells(0, 2).Resize(, Rng.Count) = Application.Transpose(Rng)
Next
End Sub
Доброе время суток. Вариант. Активная ячейка должна быть на какой-нибудь ячейкой со значением таблицы.
Код
Public Sub AppendRowInfo()
Dim vData As Variant, i As Long, k As Long
Dim pDict As Object, curRow As Long
vData = ActiveCell.CurrentRegion.Value
Set pDict = CreateObject("Scripting.Dictionary")
For i = 3 To UBound(vData, 2)
pDict(vData(1, i)) = i
Next
For i = 2 To UBound(vData, 1)
If Not IsEmpty(vData(i, 1)) Then
curRow = i
Else
vData(curRow, pDict(vData(i, 2))) = vData(i, 2)
End If
Next
ActiveCell.CurrentRegion.Value = vData
End Sub
Я здесь новичок ,прошу простить великодушно! Всем огромное Спасибо! Я только в начале пути познаний Excel.ВЫ лучшие! Ранее находил некоторые ответы в архивах.Здесь срочно по работе нужно было преобразовать кривые данные из SAP ..
Sub iTransp1()
Dim i As Long
Dim iLastRow As Long
Dim Rng As Range
Dim FoundCell As Range
iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
Range("C2:I" & iLastRow).ClearContents
For Each Rng In Range("B3:B" & iLastRow).SpecialCells(2, 1).Areas
For i = 1 To Rng.Count
Set FoundCell = Rows(1).Find(Rng.Cells(i), , xlValues, xlWhole)
Rng.Cells(0, FoundCell.Column - 1) = Rng.Cells(i)
Next
Next
End Sub