transpose data with font colour yellow to down till the next data with font colour yellow

[MasmaAbdulhamidli]

Hi.
i have long list with headers with font colour yellow. And i need transpose those values down to the right of datas. Sorry for my english, i upload example images so you can understand me. Please help. It is not important staying yellow colour

 

[mumps]

Try:

Sub transposeData()
    Application.ScreenUpdating = False
    Dim rng As Range, val As String
    For Each rng In Range("A1", Range("A" & Rows.Count).End(xlUp))
        If rng.Interior.ColorIndex = 6 Then val = rng
        If rng.Offset(1).Interior.ColorIndex = xlNone And rng.Offset(1) <> "" Then
            rng.Offset(1, 1) = val
            rng.Offset(1, 1).Interior.ColorIndex = 6
        End If
    Next rng
    Application.ScreenUpdating = True
End Sub

 

[Alex Blakenburg]

If you have a lot of data using the filter by color will be a fair bit quicker.

Sub FillDownCategories()
    Dim shtData As Worksheet
    Dim rngData As Range, rngCategories, cellCategory
    Dim lrowData As Long, i As Long
    Dim currCategory As String
    Dim arrOut As Variant
    
    Set shtData = ActiveSheet
    lrowData = shtData.Range("A" & Rows.Count).End(xlUp).Row
    Set rngData = shtData.Range("A1:A" & lrowData)
    
    If shtData.FilterMode = True Then shtData.ShowAllData
    
    rngData.AutoFilter Field:=1, Criteria1:=RGB(255, _
                    255, 0), Operator:=xlFilterCellColor

    Set rngCategories = rngData.Offset(1).Resize(rngData.Rows.Count - 1).SpecialCells(Type:=xlCellTypeVisible)
    rngData.AutoFilter
    
    rngData.Offset(1, 1).ClearContents
    arrOut = rngData.Offset(, 1)
    
    For Each cellCategory In rngCategories
        arrOut(cellCategory.Row, 1) = cellCategory.Value
    Next cellCategory
    
    For i = 2 To UBound(arrOut)
        If arrOut(i, 1) <> "" Then
            currCategory = arrOut(i, 1)
            arrOut(i, 1) = ""
        Else
            arrOut(i, 1) = currCategory
        End If
    Next i
    
    rngData.Offset(, 1) = arrOut
    ' Apply Color (optional)
    rngData.Offset(, 1).SpecialCells(xlCellTypeConstants).Interior.Color = RGB(255, 255, 0)

End Sub

 

[MasmaAbdulhamidli]

If you have a lot of data using the filter by color will be a fair bit quicker.

Sub FillDownCategories()
    Dim shtData As Worksheet
    Dim rngData As Range, rngCategories, cellCategory
    Dim lrowData As Long, i As Long
    Dim currCategory As String
    Dim arrOut As Variant
   
    Set shtData = ActiveSheet
    lrowData = shtData.Range("A" & Rows.Count).End(xlUp).Row
    Set rngData = shtData.Range("A1:A" & lrowData)
   
    If shtData.FilterMode = True Then shtData.ShowAllData
   
    rngData.AutoFilter Field:=1, Criteria1:=RGB(255, _
                    255, 0), Operator:=xlFilterCellColor

    Set rngCategories = rngData.Offset(1).Resize(rngData.Rows.Count - 1).SpecialCells(Type:=xlCellTypeVisible)
    rngData.AutoFilter
   
    rngData.Offset(1, 1).ClearContents
    arrOut = rngData.Offset(, 1)
   
    For Each cellCategory In rngCategories
        arrOut(cellCategory.Row, 1) = cellCategory.Value
    Next cellCategory
   
    For i = 2 To UBound(arrOut)
        If arrOut(i, 1) <> "" Then
            currCategory = arrOut(i, 1)
            arrOut(i, 1) = ""
        Else
            arrOut(i, 1) = currCategory
        End If
    Next i
   
    rngData.Offset(, 1) = arrOut
    ' Apply Color (optional)
    rngData.Offset(, 1).SpecialCells(xlCellTypeConstants).Interior.Color = RGB(255, 255, 0)

End Sub

Thank you very much!

 

[MasmaAbdulhamidli]

Try:

Sub transposeData()
    Application.ScreenUpdating = False
    Dim rng As Range, val As String
    For Each rng In Range("A1", Range("A" & Rows.Count).End(xlUp))
        If rng.Interior.ColorIndex = 6 Then val = rng
        If rng.Offset(1).Interior.ColorIndex = xlNone And rng.Offset(1) <> "" Then
            rng.Offset(1, 1) = val
            rng.Offset(1, 1).Interior.ColorIndex = 6
        End If
    Next rng
    Application.ScreenUpdating = True
End Sub

I appreciate. Thanks a lot!

 

[mumps]

You are very welcome.