using len(6) data to transpose

gsrikanth

Board Regular
Joined
Jan 7, 2012
Messages
210
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

u1
U±U²³U
6
U±UUUU6
U±U²³U6
uUg3
G1
U±³U4
±²UG4
´´2
U±UUUU6
µ¶2
³´µ¶·¸¹º8
»¼½¾¿5
·1
»¹´»¼½¾¿8
¸1
³´µ¶·¸¹º8
»¼½¾¿5
·1
»¹´»¼½¾¿8
¸1
U±U²³U6
uUg3
GÀÁÂÃ5
µ1
u¹u3
U±UºUU6
U±UUUU6
U±UºUU6
uUg3
G1
U±³U4
±²UG4
´´2
U±UUUU6
»¼¼3
ÄÅÆÇ4
·1
ÄÈÁÂÉÊ6
»¼½3
¿1
¸1
ÄÅÆÇ4
·1
ÄÈÁÂÉÊ6
»¼½3
¿1
¸1
U±UºUU6
uUg3
GÀÁÂÃ5
º1
2
Ë1
U±uUUU6
U±UUUU6
U±uUUU6
uUg3
G1
U±³U4
±²UG4
´´2
U±UUUU6
½³²3
ÌÍ´ÎÏÐÌgÑ9

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



U±UºUUU±UUUUU±UºUUuUgGU±³U±²UG´´U±UUUU»¼¼ÄÅÆÇ·ÄÈÁÂÉÊ»¼½¿¸ÄÅÆÇ·ÄÈÁÂÉÊ»¼½¿¸U±UºUUuUgGÀÁÂúË
U±U²³UU±UUUUU±U²³UuUgGU±³U±²UG´´U±UUUUµ¶³´µ¶·¸¹º»¼½¾¿·»¹´»¼½¾¿¸³´µ¶·¸¹º»¼½¾¿·»¹´»¼½¾¿¸U±U²³UuUgGÀÁÂõu¹u
U±uUUUU±UUUUU±uUUUuUgGU±³U±²UG´´U±UUUU½³²ÌÍ´ÎÏÐÌgÑ»¼½¾¿·»¹´»¼½¾¿¸ÌÍ´ÎÏÐÌgÑ

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

Some videos you may like

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

MarcelBeug

Well-known Member
Joined
Apr 25, 2014
Messages
1,811
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

Board Regular
Joined
Mar 5, 2016
Messages
248
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.

Code:
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

Board Regular
Joined
Jan 7, 2012
Messages
210
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.

Code:
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

Calibriu1
times new romanU±U²³U6
arialU±UUUU6
times new romanU±U²³U6
CalibriuUg3
BookmanG1
TohimaU±³U4
hemalatha±²UG4

<colgroup><col><col span="2"></colgroup><tbody>
</tbody>
 
Last edited:

shknbk2

Board Regular
Joined
Mar 5, 2016
Messages
248

ADVERTISEMENT

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

shknbk2

Board Regular
Joined
Mar 5, 2016
Messages
248
Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,123,402
Messages
5,601,475
Members
414,452
Latest member
Dannysamworth

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top