split data

[Jagathsinghangoth]

i have to require the data in following type automatically

main data is 1st row

[TABLE="width: 500"]
<tbody>[TR]
[TD]10[/TD]
[TD]11a[/TD]
[TD]12b[/TD]
[TD]15c[/TD]
[TD]18f[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]112[/TD]
[TD]11dfd[/TD]
[TD]d1f2d2[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

required as follows
[TABLE="width: 500"]
<tbody>[TR]
[TD]10[/TD]
[TD]11a[/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]12b[/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]15c[/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD]18f[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]112[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]11dfd[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]d12d2[/TD]
[/TR]
</tbody>[/TABLE]

pls suggest

 

[Joe4]

Here is one way:

Sub MyCopyData()

    Dim src As Worksheet
    Dim dst As Worksheet
    Dim lr As Long
    Dim r As Long
    Dim lc As Long
    Dim rd As Long
    
    Application.ScreenUpdating = False
    
'   Set source and destination sheets
    Set src = Sheets("Sheet1")
    Set dst = Sheets("Sheet2")
    
'   Find last row with data in column A on source sheet
    lrow = src.Cells(Rows.Count, "A").End(xlUp).Row
    
    src.Activate
'   Loop through all data
    For r = 1 To lrow
'       Find last row with data on destination sheet
        If dst.Cells(1, "A") = "" Then
            rd = 1
        Else
            rd = dst.Cells(Rows.Count, "A").End(xlUp).Row + 1
        End If
'       Copy column A to column A
        src.Cells(r, "A").Copy dst.Cells(rd, "A")
'       Find last column with data in row
        lc = src.Cells(r, Columns.Count).End(xlToLeft).Column
'       Copy paste transpose rest of data
        src.Range(Cells(r, 2), Cells(r, lc)).Copy
        dst.Cells(rd, "B").PasteSpecial Transpose:=True
        Application.CutCopyMode = False
'       Fill in the rest of column A
        If lc > 2 Then
            Range(dst.Cells(rd + 1, "A"), dst.Cells(rd + lc - 2, "A")) = dst.Cells(rd, "A")
        End If
    Next r
    
    Application.ScreenUpdating = True
    
End Sub

 

[MickG]

Another Option
Results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG16Jun14
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("A1").CurrentRegion
ReDim ray(1 To Rng.Count, 1 To 2)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Rows
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dn.Cells
        [COLOR="Navy"]If[/COLOR] Not R.Value = Dn.Cells(1).Value And R.Value <> "" [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            ray(c, 1) = Dn.Cells(1).Value
            ray(c, 2) = R
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] Dn
Sheets("Sheet2").Range("A1").Resize(c, 2).Value = ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick