Transpose single column of data to multiple columns at blank row breaks

[chzhd4life]

Help, have multiple very long "tables" of data in a single column. Need to transpose/convert to standard table format. Entries are divided by blank row or rows. Not all entries have same pieces of data, e.g., some have Name, Address, City/ST/Zip, Phone, email, website URL, etc. Others may be missing some pieces of information. Found a macro (below) that described my same scenario but it's not working (run-time error 1004) and when I debug it appears to be getting hung up at "Cells(strt, 1).Resize(nd - strt).Copy". Help?

Sub Paste_Transpose()
Dim LastRow As Long, x As Long
Dim PasteRow As Long
Dim strt As Long, nd As Long
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
PasteRow = 1
For x = 1 To LastRow + 1
If Len(Cells(x, 1)) = 0 And strt = 0 And nd = 0 Then
strt = Cells(x, 1).Row + 1
Else
If strt > 0 And Len(Cells(x, 1)) = 0 Then
nd = Cells(x, 1).Row
'paste transpose
Cells(strt, 1).Resize(nd - strt).Copy
Cells(PasteRow, 2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
strt = 0
nd = 0
x = x - 1
PasteRow = PasteRow + 1
End If
End If
Next
Application.CutCopyMode = False
'Columns(1).Delete
End Sub

 

[chzhd4life]

Darn, missed that, maxcol=7

 

[DanteAmor]

Here's an example of what it's doing in my most current example … I was thinking that because there's a blank between Prairie City OR and the phone number, it thinks it should start a NEW record with the phone number, when in fact everything up through the URL is one record and the new entry shouldn't start until after the TWO blank rows because all data up to the two blank rows is one record.

Data in left yellow column A is the original, data in columns B-H is what the macro did. Three entries starting in row with phone number belong to the record above it.

Don't get me wrong, it's AWESOME and I can happily make the occasional edits, just wondered if there was a way to easily modify the macro when I had a scenario like this. THANKS!!!
View attachment 3407

According to your example, this should work for you.

Sub Paste_Transpose_1()
  Dim c As Range, d As Range, wu As Boolean, a As Variant
  Range("B:Z").ClearContents
  For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
    Set d = c
    If wu = False Then
      If d.Cells(d.Rows.Count, 1).Offset(2) <> "" Then
        Set a = Range(d.Cells(d.Rows.Count, 1).Offset(2), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
        Set d = Union(d.Resize(d.Rows.Count + 1, 1), a(1))
        wu = True
      End If
      Range("B" & Rows.Count).End(xlUp)(2).Resize(1, d.Rows.Count).Value = Application.Transpose(d.Value)
    Else
      wu = False
    End If
  Next
End Sub

 

[Peter_SSs]

Darn, missed that, maxcol=7

What happens if you add in this line where shown?

  Next i
  ReDim Preserve b(1 To UBound(b), 1 To maxcol)
  Range("B2").Resize(r, maxcol).Value = b
End Sub

 

[DanteAmor]

Hi @chzhd4life,

Forget the post code #12.

With the following you can even have lost several data between the lines; but not 2 consecutive blanks, because then it is considered as a new block.

Ej:

Book1
	A	B	C	D	E	F	G	H	I
1
2	FIELD	FIELD	PROD		PRAI		541	FIELD	HTTP
3	PROD	FINE	PRODUCTS	HILLS	DAVIE	719	FINEFETT	HTTP
4		COMPANY	PRODUC X	NA 12		888	ABC	HTTP
5	PRAI
6
7	541
8	FIELD
9	HTTP
10
11
12	FINE
13	PRODUCTS
14	HILLS
15	DAVIE
16	719
17	FINEFETT
18	HTTP
19
20
21	COMPANY
22	PRODUC X
23	NA 12
24
25	888
26	ABC
27	HTTP
Hoja14

Try this:

Sub Paste_Transpose_5()
  Dim c As Range
  Application.ScreenUpdating = False
  For Each c In Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeBlanks).Areas
    If c.Rows.Count = 1 Then c.Value = "###"
  Next
  For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
    Range("B" & Rows.Count).End(xlUp)(2).Resize(1, c.Rows.Count).Value = Application.Transpose(c.Value)
  Next
  ActiveSheet.Cells.Replace "###", "", xlWhole, xlByRows, False, False, False
End Sub

 

[chzhd4life]

THANKS! That fixed the issues where I have two consecutive blanks, BUT I then found a version where I have THREE blanks, and it's still doing same, starting new entry too early. Can you tell me where in the code I might edit when I run into that or similar scenarios?

THANKS AGAIN!

 

[DanteAmor]

THANKS! That fixed the issues where I have two consecutive blanks, BUT I then found a version where I have THREE blanks, and it's still doing same, starting new entry too early. Can you tell me where in the code I might edit when I run into that or similar scenarios?

THANKS AGAIN!

You can put a picture of how your data is and how you want the result.

 

[chzhd4life]

Yellow is small section of original data, orange is first instance of where it stopped transposing one row too soon

 

[DanteAmor]

Yellow is small section of original data, orange is first instance of where it stopped transposing one row too soon

So the pattern should not be blank cells as you suggest in the initial post "Entries are divided by blank row or rows"
The pattern should be every 7 lines 2 spaces, then again 7 lines 2 spaces:

I guess it starts in cell A2. Then try the following:

Sub Paste_Transpose_6()
  Dim c As Range, j As Long
  j = 2
  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row Step 9
    Range("B" & j).Resize(1, 7).Value = Application.Transpose(Range("A" & i).Resize(7, 1).Value)
    j = j + 1
  Next
End Sub

 

[chzhd4life]

In this case it's 7, but not always.... Thanks for this code, I'll likely utilize all three in various scenarios! Thanks again so much!

 

[DanteAmor]

In this case it's 7, but not always.... Thanks for this code, I'll likely utilize all three in various scenarios! Thanks again so much!

If you find a pattern for all scenarios, I will gladly make the changes.

Nice to help you, thanks for the feedback.