Страницы: 1
RSS
Транспонировать несколько столбцов разной высоты, Требуется транспонировать данные разной высоты
 
Требуется транспонировать столбцы разной высоты  в примере выделены красным шрифтом ,в строчки напротив артикулов (выделены желтой заливкой)  с условием что номера 5029,5030 и  т.д. подстанавливаются в столбцы с аналогичными номерами.  Артикулов  обычно  т  3000 и более ,а вариантов высоты столбцов  от 1 до 7 (5029,5030,5031,5032,5033,5039,5042)
Изменено: Дмитрий Челноков - 17.07.2020 21:45:37
 
Дмитрий Челноков, а можно показать желаемый результат?
наугад
Код
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
Изменено: Mershik - 17.07.2020 22:10:05
Не бойтесь совершенства. Вам его не достичь.
 
Код
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
 
Mershik,
Вот так  
 
Доброе время суток.
Вариант. Активная ячейка должна быть на какой-нибудь ячейкой со значением таблицы.
Код
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
 
Mershik,  спасибо ,работает!
 
Дмитрий Челноков, а почему другим помощникам не отвечаете? да и за такое цитирование будут вас ругать модераторы
Не бойтесь совершенства. Вам его не достичь.
 
Я здесь новичок ,прошу простить великодушно! Всем огромное Спасибо! Я только в начале пути познаний 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
Страницы: 1
Наверх