Transpose row to column but with different issue

[fahadmalik09]

Hey Forum,

[TABLE="width: 50"]
<tbody>[TR]
[TD]Name1[/TD]
[/TR]
[TR]
[TD]Email1[/TD]
[/TR]
[TR]
[TD]Mobile1[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Name 2[/TD]
[/TR]
[TR]
[TD]Mobile 2[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Name 3[/TD]
[/TR]
[TR]
[TD]Email 3[/TD]
[/TR]
[TR]
[TD]Mobile 3[/TD]
[/TR]
[TR]
[TD]Mobile3[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

The above data has 3 as well as 2 values
i need to transpose Name Mobile Email where some email has no data(blank column)
Some has duplicate Mobile number like in above its Mobile3

As soon as i remove duplicate, it also remove empty column between 2 data

I want to make it like this below

[TABLE="width: 50"]
<tbody>[TR]
[TD]Name1[/TD]
[TD]Email1[/TD]
[TD]Mobile1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name2[/TD]
[TD][/TD]
[TD]Mobile2[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name3[/TD]
[TD]Email3[/TD]
[TD]Mobile3[/TD]
[TD]Mobile3[/TD]
[/TR]
[TR]
[TD]Name4[/TD]
[TD]Email4[/TD]
[TD]Mobile4[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

If this can be done, i can delete Mobile 3 duplicate contact afterward
Note: Few column has email and few don't have.

I tried concatenate and added all the values, then used comma to separate values and then text to column. But i am doing manually. i dont know how this can be done in 6000+ column.

Help me guys. Thanks in advance

Best Regards

 

[Kamolga]

This code will do it if your data is in column A. You should remove empty rows and duplicates before running it (remove duplicate functionality)

Sub TransposedATA()
Application.ScreenUpdating = False
[COLOR=#008000]'Define the amount of Rows in ColumnA Sheet1[/COLOR]
  Dim Sh As Worksheet
[COLOR=#008000]  'Change Sheet1 with name of the sheet (Leave the "")[/COLOR]
   Set Sh = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
   Sh.Activate
 [COLOR=#008000] 'Last Row [/COLOR]
   Dim lr As Long
   lr = Sh.Cells(Sh.Rows.Count, "A").End(xlUp).Row
   [COLOR=#008000]'Use j as row where the name is[/COLOR]
          Dim j As Long
         [COLOR=#008000] 'Name1 is in row 1 so start with line1[/COLOR]
          j = [COLOR=#ff0000]1[/COLOR]
  '[COLOR=#008000]Loop through each cell[/COLOR]
   Dim i As Long
    i = j
     For i = j To lr
       [COLOR=#008000]   'Cut the cell[/COLOR]
          Range("A" & i).Cut
        [COLOR=#008000]'if cell in row i column 1 is an email[/COLOR]
         If Range("A" & i) Like "*@*" Then
             Range("B" & j).Select
                ActiveSheet.Paste
         [COLOR=#008000] 'if it has a number and no @, it is a phone number[/COLOR]
         ElseIf HasNumber(Cells(i, 1)) = True Then
              [COLOR=#008000]'if there is already a number in column C[/COLOR]
              If Range("C" & j) = "" Then
                Range("C" & j).Select
                Else
                Range("D" & j).Select
              End If
                ActiveSheet.Paste
         [COLOR=#008000] 'Otherwise this is the name of a person (new row to paste at)[/COLOR]
         Else
            j = i
         End If
     Next i
    [COLOR=#008000] 'Delete empty rows (where there is no name)[/COLOR]
     Range("a1:a" & lr).Select
     Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Function HasNumber(oRng As Range) As Boolean
     Dim bHasNumber As Boolean, l As Long
     bHasNumber = False
     For l = 1 To Len(oRng.Text)
         If IsNumeric(Mid(oRng.Text, l, 1)) Then
             bHasNumber = True
             Exit For
         End If
     Next
     HasNumber = bHasNumber
End Function

If you never used a macro, the simplest way is right click the sheet name, click vew code, go to insert menu and chose module. Paste the code there and put your cursor between Sub TransposedATA() and end sub. Now click the play button.
Note: try on a copy, there is no undo with macros