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]

30013

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 SubBasically, 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.