Transpose data

[jillibillijames]

Hi,

i have data in this format.

<TABLE style="WIDTH: 48pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=64><COLGROUP><COL style="WIDTH: 48pt" width=64><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; WIDTH: 48pt; HEIGHT: 15pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20 width=64>company</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20>address</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20>tel</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20>contact</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20> </TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20>company</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20>address</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20>tel</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20>contact</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20>email</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: windowtext; BORDER-RIGHT: windowtext 0.5pt solid" class=xl65 height=20>fax</TD></TR></TBODY></TABLE>
there are nearly 400 companies in this format with blank cell between the first company details and the second. i wanted this data to be placed in rows. there are too many to use transpose option.

can anyone help me out of this.

Thanks in advance.

James

 

[moonfish]

Assuming all your data is in column A, starting at A1, this will put the transposed values in columns C and upward.

Sub TransposeCompanies()
    Dim i, j, k As Integer
    j = 1
    k = 0
    
    For i = 1 To ActiveSheet.UsedRange.Rows.Count
        If Cells(i, 1).Value = "" Then
            j = j + 1
            k = 0
        Else
            Cells(j, 3 + k) = Cells(i, 1)
            k = k + 1
        End If
    Next i
End Sub

 

[Jon von der Heyden]

This places the results in a new sheet, and must be triggered while the sheet with this data is the active sheet:

Public Sub Boooooooooooo()
    Dim varArray1 As Variant, varArray2 As Variant
    Dim strVals As String
    Dim wks As Worksheet
    Dim lngRow As Long
    
    varArray1 = Application.Transpose(Intersect(Columns(1), ActiveSheet.UsedRange).Value2)
    strVals = Replace$(Join$(varArray1, ","), ",,", vbCrLf)
    
    Set wks = Sheets.Add
    
    For lngRow = 1 To Len(strVals) - Len(Replace$(strVals, vbCrLf, ""))
        varArray2 = Split(Split(strVals, vbCrLf)(lngRow - 1), ",")
        wks.Range("A" & lngRow).Resize(1, UBound(varArray2) + 1).Value = varArray2
    Next lngRow
End Sub

 

[cgcamal]

Hi jillibillijames,

The same assumption, data is in column A and begins in A1. Transposed data will be showed beginning in column B.

Sub Transpose()
Dim wf As WorksheetFunction, m As Integer, O As Integer, c As Integer

Set wf = WorksheetFunction
m = 1: O = 1
For Each r In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    If r.Address = "$A$2" Or IsEmpty(Range(r.Address).Offset(-1, 0)) Then
        c = Range(r.Address).End(xlDown).Row - r.Row + 1 + O
        Cells(m, "B").Resize(, c) = wf.Transpose(Range(r.Address).CurrentRegion)
        m = m + 1
    End If
    O = 0
Next
End Sub

Regards

 

[Rick Rothstein]

One more...

Sub TransposeData()
  Dim LastRow As Long, A As Range
  Const StartRow As Long = 2
  Const DataCol As String = "A"
  LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
  For Each A In Cells(StartRow, DataCol).Resize(LastRow - StartRow + 1).SpecialCells(xlCellTypeConstants).Areas
    A(1).Resize(, A.Rows.Count) = WorksheetFunction.Transpose(A.CurrentRegion)
  Next
  Cells(StartRow, DataCol).Offset(, 1).Resize(LastRow - StartRow + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Before you run the code, set the two constants (Const statements) to match your set up (StartRow is first company's row number, DataCol is the column your data is in).

 

[jillibillijames]

Hi,
it worked. Can you please give me a code for the data with multiple blanks in between.

Thanks in advance,
James

 

[moonfish]

Sub TransposeCompanies()
    Dim i, j, k As Integer
    j = 1
    k = 0
    
    For i = 1 To ActiveSheet.UsedRange.Rows.Count
        If Cells(i, 1).Value = "" Then
            j = j + 2
            k = 0
        Else
            Cells(j, 3 + k) = Cells(i, 1)
            k = k + 1
        End If
    Next i
End Sub

This way it adds a blank line between each entry. If you want more blank lines between each entry, change the value colored red in the above code.

If you want the transposed data to be directly adjacent to its original data, replace the red value with k + 1.

 

[Rick Rothstein]

it worked. Can you please give me a code for the data with multiple blanks in between.

You should really try all of the code offerings you receive to questions you ask. Had you done that, you would have found that the code I offered you already has the functionality you are now asking for built into it. I haven't looked at the other solutions myself (no reason for me to have as it was not my question), but it is possible that one or more of them might also already do it too.

 

[Rick Rothstein]

You should really try all of the code offerings you receive to questions you ask. Had you done that, you would have found that the code I offered you already has the functionality you are now asking for built into it. I haven't looked at the other solutions myself (no reason for me to have as it was not my question), but it is possible that one or more of them might also already do it too.

Okay, I just looked at moonfish's response and see that he interpretted your latest question differently from the way I did. When you said "Can you please give me a code for the data with multiple blanks in between", did you mean you wanted the code to be able to handle multiple blank lines between your existing data (which is what I assumed you meant) or that you wanted the output from our code to produce transformed data with more than one blank line between the output (which is what moonfish assumed you meant)?

 

[jillibillijames]

Hi,

I just checked my entire data and i found few companies come in the same row. I also tried with other codes as well but showing runtime error "9" and "1004". I managed deleting multiple blanks and maintained only single blank.

Can anyone please help me out.

And thanks everyone for the quick reply to my query.

Regards
JillibilliJames