using len(6) data to transpose

[gsrikanth]

all the data in column A only in column Column B length formula

transpose the data when continuous 3 cells len "6" "6" "6". data example

u	1
U±U²³U	6
U±UUUU	6
U±U²³U	6
uUg	3
G	1
U±³U	4
±²UG	4
´´	2
U±UUUU	6
µ¶	2
³´µ¶·¸¹º	8
»¼½¾¿	5
·	1
»¹´»¼½¾¿	8
¸	1
³´µ¶·¸¹º	8
»¼½¾¿	5
·	1
»¹´»¼½¾¿	8
¸	1
U±U²³U	6
uUg	3
GÀÁÂÃ	5
µ	1
u¹u	3
U±UºUU	6
U±UUUU	6
U±UºUU	6
uUg	3
G	1
U±³U	4
±²UG	4
´´	2
U±UUUU	6
»¼¼	3
ÄÅÆÇ	4
·	1
ÄÈÁÂÉÊ	6
»¼½	3
¿	1
¸	1
ÄÅÆÇ	4
·	1
ÄÈÁÂÉÊ	6
»¼½	3
¿	1
¸	1
U±UºUU	6
uUg	3
GÀÁÂÃ	5
º	1
u¹	2
Ë	1
U±uUUU	6
U±UUUU	6
U±uUUU	6
uUg	3
G	1
U±³U	4
±²UG	4
´´	2
U±UUUU	6
½³²	3
ÌÍ´ÎÏÐÌgÑ	9

<colgroup><col><col></colgroup><tbody>
</tbody>

U±UºUU

U±UUUU

U±UºUU

uUg

G

U±³U

±²UG

´´

U±UUUU

»¼¼

ÄÅÆÇ

·

ÄÈÁÂÉÊ

»¼½

¿

¸

ÄÅÆÇ

·

ÄÈÁÂÉÊ

»¼½

¿

¸

U±UºUU

uUg

GÀÁÂÃ

º

u¹

Ë

U±U²³U

U±UUUU

U±U²³U

uUg

G

U±³U

±²UG

´´

U±UUUU

µ¶

³´µ¶·¸¹º

»¼½¾¿

·

»¹´»¼½¾¿

¸

³´µ¶·¸¹º

»¼½¾¿

·

»¹´»¼½¾¿

¸

U±U²³U

uUg

GÀÁÂÃ

µ

u¹u

U±uUUU

U±UUUU

U±uUUU

uUg

G

U±³U

±²UG

´´

U±UUUU

½³²

ÌÍ´ÎÏÐÌgÑ

»¼½¾¿

·

»¹´»¼½¾¿

¸

ÌÍ´ÎÏÐÌgÑ

<colgroup><col style="width:48pt" span="28" width="64"> </colgroup><tbody>
</tbody>

 

[MarcelBeug]

If source data is in Sheet1 and destination is Sheet2, add a few helper columns and a header row, so data starts at row 2.

Sheet1!C2 and down: =SUM(C1,3=COUNTIF(B2:B4,6))
Sheet2!A2 and down: =IFNA(MATCH(ROW()-1,Sheet1!C:C,0),"")
Sheet2!B2 and down: =COUNTIF(Sheet1!C:C,ROW()-1)

Result from Sheet2!C2 to the right and down: =IF($A2="","",IF(COLUMNS($C2:C2)>$B2,"",INDEX(Sheet1!$A:$A,$A2+COLUMNS($C2:C2)-1)))

 

[shknbk2]

Here is a way to do it with VBA. Change the rDataFirstCell and rTransposeDestination cells in the code based on where your data is and where you want it transposed to.

Type aArray
    a() As Variant
End Type


Sub transposeData()
    Dim a(), aT() As aArray
    Dim i As Long, j As Long, k As Long
    Dim aTcount As Long, tStart As Long, tEnd As Long
    Dim rDataFirstCell As Range, rTransposeDestination As Range
    
    Set rDataFirstCell = Range("A1")
    Set rTransposeDestination = Range("D1")
    rTransposeDestination.CurrentRegion.Clear
    
    a = Range(rDataFirstCell, rDataFirstCell.End(xlDown).Offset(0, 1)).Value
    tStart = 1
    aTcount = 0
    For i = 2 To UBound(a) - 2
        If a(i, 2) = 6 And a(i + 1, 2) = 6 And a(i + 2, 2) = 6 Then
            tEnd = i - 1
            aTcount = aTcount + 1
            ReDim Preserve aT(1 To aTcount)
            ReDim Preserve aT(aTcount).a(1 To tEnd - tStart + 1)
            k = 0
            For j = tStart To tEnd
                k = k + 1
                 aT(aTcount).a(k) = a(j, 1)
            Next
            tStart = i
        End If
    Next
    tEnd = UBound(a)
    aTcount = aTcount + 1
    ReDim Preserve aT(1 To aTcount)
    ReDim Preserve aT(aTcount).a(1 To tEnd - tStart + 1)
    k = 0
    For j = tStart To tEnd
        k = k + 1
         aT(aTcount).a(k) = a(j, 1)
    Next
    
    For k = 1 To aTcount
        rTransposeDestination.Offset(k - 1, 0).Resize(1, UBound(aT(k).a)) = aT(k).a
    Next
End Sub

 

[gsrikanth]

Here is a way to do it with VBA. Change the rDataFirstCell and rTransposeDestination cells in the code based on where your data is and where you want it transposed to.

private Type aArray
    a() As Variant
End Type


Sub transposeData()
    Dim a(), aT() As aArray
    Dim i As Long, j As Long, k As Long
    Dim aTcount As Long, tStart As Long, tEnd As Long
    Dim rDataFirstCell As Range, rTransposeDestination As Range
    
    Set rDataFirstCell = Range("A1")
    Set rTransposeDestination = Range("D1")
    rTransposeDestination.CurrentRegion.Clear
    
    a = Range(rDataFirstCell, rDataFirstCell.End(xlDown).Offset(0, 1)).Value
    tStart = 1
    aTcount = 0
    For i = 2 To UBound(a) - 2
        If a(i, 2) = 6 And a(i + 1, 2) = 6 And a(i + 2, 2) = 6 Then
            tEnd = i - 1
            aTcount = aTcount + 1
            ReDim Preserve aT(1 To aTcount)
            ReDim Preserve aT(aTcount).a(1 To tEnd - tStart + 1)
            k = 0
            For j = tStart To tEnd
                k = k + 1
                 aT(aTcount).a(k) = a(j, 1)
            Next
            tStart = i
        End If
    Next
    tEnd = UBound(a)
    aTcount = aTcount + 1
    ReDim Preserve aT(1 To aTcount)
    ReDim Preserve aT(aTcount).a(1 To tEnd - tStart + 1)
    k = 0
    For j = tStart To tEnd
        k = k + 1
         aT(aTcount).a(k) = a(j, 1)
    Next
    
    For k = 1 To aTcount
        rTransposeDestination.Offset(k - 1, 0).Resize(1, UBound(aT(k).a)) = aT(k).a
    Next
End Sub

i want to add

* Range("B" & i).Font.Name = Range("A" & i).Value

in column "A" fonts are there

From the above program font not reflect by using * it will change
how to add above * code to program

table ex

Calibri	u	1
times new roman	U±U²³U	6
arial	U±UUUU	6
times new roman	U±U²³U	6
Calibri	uUg	3
Bookman	G	1
Tohima	U±³U	4
hemalatha	±²UG	4

<colgroup><col><col span="2"></colgroup><tbody>
</tbody>

 

[shknbk2]

Are the fonts in the transpose area supposed to have the fonts or just row B?

 

[gsrikanth]

Are the fonts in the transpose area supposed to have the fonts or just row B?

The fonts in the transpose area supposed to have the fonts

 

[shknbk2]

Type aArray
     a() As Variant
 End Type

 Sub transposeData()
    Dim a(), aT() As aArray
    Dim i As Long, j As Long, k As Long
    Dim aTcount As Long, tStart As Long, tEnd As Long
    Dim rDataFirstCell As Range, rTransposeDestination As Range
    Dim fontCell As Range, r As Range
    
    Set fontCell = Range("A1")
    Set rDataFirstCell = Range("B1")
    Set rTransposeDestination = Range("E1")
    rTransposeDestination.CurrentRegion.Clear
    
    a = Range(rDataFirstCell, rDataFirstCell.End(xlDown).Offset(0, 1)).Value
    tStart = 1
    aTcount = 0
    For i = 2 To UBound(a) - 2
        If a(i, 2) = 6 And a(i + 1, 2) = 6 And a(i + 2, 2) = 6 Then
            tEnd = i - 1
            aTcount = aTcount + 1
            ReDim Preserve aT(1 To aTcount)
            ReDim Preserve aT(aTcount).a(1 To tEnd - tStart + 1)
            k = 0
            For j = tStart To tEnd
                k = k + 1
                 aT(aTcount).a(k) = a(j, 1)
            Next
            tStart = i
        End If
    Next
    tEnd = UBound(a)
    aTcount = aTcount + 1
    ReDim Preserve aT(1 To aTcount)
    ReDim Preserve aT(aTcount).a(1 To tEnd - tStart + 1)
    k = 0
    For j = tStart To tEnd
        k = k + 1
         aT(aTcount).a(k) = a(j, 1)
    Next
    
    For k = 1 To aTcount
        rTransposeDestination.Offset(k - 1, 0).Resize(1, UBound(aT(k).a)) = aT(k).a
    Next
    
    j = -1
    k = 0
    For Each r In Range(fontCell, fontCell.End(xlDown))
        j = j + 1
        If rTransposeDestination.Offset(k, j).Value = "" Then
            j = 0
            k = k + 1
        End If
        rTransposeDestination.Offset(k, j).Font.Name = r.Value
    Next
 End Sub