View Full Version : Nasty spreadsheet
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!
Integrate your data into 1 worksheet. No need to split similar data in monthly sheets
Add a column, named 'month'.
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
07-29-2022, 01:26 PM
Probably easier to visualize if you could attach it (without any sensitive data if necessary)
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.
I don't see 12 Tabs.
This can't be a representative sample.
Aussiebear
07-30-2022, 03:07 PM
@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
07-30-2022, 03:12 PM
@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
07-30-2022, 06:16 PM
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
07-30-2022, 07:22 PM
Nicely done Paul.
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
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
@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
@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
07-31-2022, 10:45 AM
@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
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
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.
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.