Nasty spreadsheet

[PamK]

I have a spreadsheet with 12 tabs. Everything is workable in the first 7 tabs.
However tab 8 has all data entered in column A on multiple rows. There is a blank row between data sets. I need to transpose this data into columns. The data elements are as follows: name, title, email, unidentified code, city, comments.

The following tabs are similar. I haven't done this in a very long time, but I know there is a way to tanspose the data into columns where an empty row separates each record.
Any help would be greatly apreciated!

[snb]

Integrate your data into 1 worksheet. No need to split similar data in monthly sheets
Add a column, named 'month'.

[PamK]

I'm trying to integrate into 1 spreadsheet. That was what my question was. Everything is listed in column a and I need to populate columns B through G

[Paul_Hossler]

Probably easier to visualize if you could attach it (without any sensitive data if necessary)

[PamK]

Here is a short sample of the data. As you can see, everything is in column A and I need it, as stated before, need it in separate columns.

[snb]

I don't see 12 Tabs.
This can't be a representative sample.

[Aussiebear]

@snb, why would you need to see 12 tabs? In the initial post PamK indicated it's the 8th tab that is the problem.

[Aussiebear]

@PamK, How often does the data grouping (6 rows) contain missing fields ( either by way of as in Contact 3 -no email blank row, or no city - missing row).

[Paul_Hossler]

Capture.JPG

Not perfect since the number of lines in each block varies

I tried to handle at least one special case

Option Explicit


Sub TryNumber_01()
    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim rowLast As Long, rowOut As Long, rowBlock As Long, colOut As Long
    Dim cntBlocks As Long, aryBlocks() As Long, outBlocks As Long


    Set wsIn = Worksheets("Sheet1")
    Set wsOut = Worksheets("Sheet2")


    With wsIn
        rowLast = .Cells(.Rows.Count, 1).End(xlUp).Row
        
        cntBlocks = 0
    
        For rowBlock = 1 To rowLast
            If .Cells(rowBlock, 1).Hyperlinks.Count = 1 And InStr(.Cells(rowBlock, 1).Value, "@") = 0 Then
                cntBlocks = cntBlocks + 1
                ReDim Preserve aryBlocks(1 To cntBlocks)
                aryBlocks(cntBlocks) = rowBlock
            End If
        Next rowBlock
    End With
    
    cntBlocks = cntBlocks + 1
    ReDim Preserve aryBlocks(1 To cntBlocks)
    aryBlocks(cntBlocks) = rowLast + 2
    
    With wsOut
        .Cells(1, 1).CurrentRegion.ClearContents
        
        rowOut = 1
        
        For outBlocks = LBound(aryBlocks) To UBound(aryBlocks) - 1
        
            colOut = 1
            For rowBlock = aryBlocks(outBlocks) To aryBlocks(outBlocks + 1) - 2
                .Cells(rowOut, colOut).Value = wsIn.Cells(rowBlock, 1).Value
                colOut = colOut + 1
                
                'try handle some missing data
                If (aryBlocks(outBlocks + 1) - 2 - aryBlocks(outBlocks) = 4) And (colOut = 5) Then
                    colOut = colOut + 1
                End If
            
            Next rowBlock
            
            rowOut = rowOut + 1
        
        Next outBlocks
    End With
    


    MsgBox "Done"
    
End Sub

[Aussiebear]

Nicely done Paul.

[SamT]

Caveats:
I don't have MS Office on this Computer, so this is all from memory
I can't see your attachment, so I am going by Paul's post
I am using the original sheets. If after testing on a copy, you like the outcome, delete columns A:B and Filter_Unique the remainder to get rid of empty Rows
BruteForce. One (5) time use. Open each Tab in turn and run this Procedure
3 lines of code + setup

Sub TransposeByBlock()
Dim LR As Long
Dim Rw as Long
Dim WSF As Object
Set WSF = WorksheetFunction

With ActiveSheet
LR = Cells(Rows.Count, "A").End(xlUp).Row

For Rw = 1 to LR Step 7
   Cells(Rw, "A").Offset(0, 3).Resize(1, 6)= WSF.Transpose(Cells(Rw, "A").Resize(6, 1))
Next Rw

End With
End Sub

[snb]

Sub M_snb()
  For Each it In Columns(1).SpecialCells(2).Areas
    sn = Application.Transpose(it)
    If it.Count > 1 And it.Count < 5 Then sn = Application.Transpose(it.Resize(6))
     
    If b And it.Count > 1 And it.Count < 5 Then
      b = False
    Else
      b = it.Count > 1 And it.Count < 5
      If IsArray(sn) Then Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(, UBound(sn)) = sn
    End If
  Next
End Sub

[SamT]

@snb,
IMO,
If b And ... will never be true
Which doesn't matter as b is not used anywhere in any decision code

Given random empty cells, ex: "email" is empty but no others, there will be extraneous "Garbage" output lines

[snb]

@Sam

You didn't test, I did in the provided sample file
b is used in the line:

If b And it.Count > 1 And it.Count < 5 Then

[Paul_Hossler]

@snb,
IMO,
If b And ... will never be true
Which doesn't matter as b is not used anywhere in any decision code

Actually 'b' gets set several lines farther down

 b = it.Count > 1 And it.Count < 5

[SamT]

If b And it.Count > 1 And it.Count < 5 Then

b is false at that time
Where is b use for anything other than setting b?

b = it.Count > 1 And it.Count < 5

Ignores the edge case wherein it.count = 5 and doesn't even effect the next line.

    If b And it.Count > 1 And it.Count < 5 Then
      b = False
    Else
      b = it.Count > 1 And it.Count < 5
      If IsArray(sn) Then Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(, UBound(sn)) = sn
    End If

Can be refactored to

If IsArray(sn) Then Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(, UBound(sn)) = sn

Your entire code can be refactored to

 
Sub M_snb()
  For Each it In Columns(1).SpecialCells(2).Areas
    Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(, 6) =  Application.Transpose(it.Resize(6))
  Next
End Sub

Basically, the same three lines as in my example, with the advantage of yours being that no Filter Unique is needed for cleanup.
But will still have spurious returns when the "Email" line is the only empty line in any 6 line Data block



To combine the best of yours with mine would be to edit my 3 code lines to read

For Rw = 1 to LR Step 7
   Cells(Rows.Count, "D").End(xlUp).Offset(1).Resize(, 6) = WSF.Transpose(Cells(Rw, "A").Resize(6)) 
Next Rw

I recognize that my offering is based on the assumption that the actual raw Data is exactly 6 Rows of Data followed by 1 empty Row



And I did have another error:

Set WSF = WorksheetFunction

Should read

Set WSF = Application.WorksheetFunction

[snb]

I recognize that my offering is based on the assumption that the actual raw Data is exactly 6 Rows of Data followed by 1 empty Row

Alas, your assumption doesn't match the sample file.
Please use the sample file to check your assertions.