Solved: Columns to Rows keeping data integrity

[monkeydt]

Hi everyone, thanks for any help you can give in advance.

As a small charity we don't have skills, resources etc to get someone in to help, so we are a little desperate!! We're not sure if VBA is the answer...

We have a list of data in a worksheet (called intermediate step), relating to a public consultation. Each row represents a part of a written response. I.e a1 is a unique id b1 responder name c1 responder category d1 part of the response. Each part of a response is mapped to a theme e.g zoology studies and is in column e1. However, each response could have multiple themes, so f1 could be zoo maintenance and so forth up to 5 different themes. I need to get each theme from the columns into individual rows, but with the information as in a1:d1. So, the sheet would show all themes in column e, but as in the example above, zoology studies and zoo maintenance would have separate rows, but the same data in columns a:d. Is there a way of doing this automatically?

I have copied some examples of how the sheet is now, and how I would like it to look.

See attached sheet, many thanks for your help.

FYI as a charity we don't have skills, resources etc to get someone in to help, so we are a little desperate!!

[GTO]

Greetings monkeydt,

I see that this is your first post; let me be the first to say - welcome to vbaexpress:hi:.

In your example file, I see that you show the after/desired layout on the same sheet. I would assume that we would want the data layed out on a new sheet, is that correct?

Also, are we going to keep the records together as shown, or would we want a seperate sheet for each unique ID?

Mark

[monkeydt]

Hi GTO, thanks for the welcome, it's nice to be here!

All of the data is in a worksheet call 'intermediate step' (as once we have sorted the data - we have to do final analysis/dashbaords etc)...all of the columns are laid out as in the worksheet.

The 'after' example was just to highlight how it would ideally look, but no it would be ideal on a seperate sheet...I just put the example on one page for ease.

No the unique ID must be the same, the Id's run from 39DT10 to 802DT11 (the last two digits being the year received). So if xxxDTxx in row 4 has themes of Zoo breeding and Zoo maintenance when they were in new seperate rows they must have the same (xxxDTxx) unique ID. So ideally we would want the records kept together in the same sheet, no on seperate sheets, as in the example.

It enables us to reference the analysed response to the saved full word doc response.

Am I being totally confusing? Sorry if I am,

[monkeydt]

Have I scared everyone off? :)

[shrivallabha]

Certainly not. People come here on their own time. See the code below to get you started.
Sub ArrangeTable()
Dim lLastRow As Long, lLastCol As Long
Application.ScreenUpdating = False
'Removing previous data if any
Sheets("Result").Cells.ClearContents
'The main work we'll do in this sheet
With Sheets("Intermediate Step")
'Finding the last row of the data in this sheet
lLastRow = .Range("A" & Rows.Count).End(xlUp).Row
'Since data begins at row 4
For i = 4 To lLastRow
'checkign the last data column
lLastCol = Cells(i, Columns.Count).End(xlToLeft).Column
'Since unrepeated trend begins at column 8
For j = 8 To lLastCol
.Range("A" & i).Resize(, 7).Copy
ActiveSheet.Paste Destination:= _
Sheets("Result").Range("A" & Rows.Count).End(xlUp)(2) 'Finding the next empty row
Application.CutCopyMode = False
Cells(i, j).Copy
ActiveSheet.Paste Destination:= _
Sheets("Result").Range("H" & Rows.Count).End(xlUp)(2)
Application.CutCopyMode = False
Next j
Next i
End With
Application.ScreenUpdating = True
End Sub

I am attaching the revised workbook with the macro. You can use standard ALT+F8 shortcut to invoke macro or goto the developer tab and select macro from there.

PS: I forgot the attachment in while submitting. If you use it then the results will get copied to the new worksheet!

[monkeydt]

Oh my goodness, that works amazingly well. I/we cannot thank you enough.

I will keep playing with it and can I come back to you with questions regarding the code later?

MASSIVE thank you!!!!!

[GTO]

Sorry about that, I had a chance to write an example, but connectivity issues (my end, not the site's) and then got busy.

I see that Shrivallabha has already given you a fine example and this is similar, but since already written and just in case it helps...

In a Standard Module:

Option Explicit

Sub ParseRecords()
Dim _
wksData As Worksheet, _
wksOutput As Worksheet, _
rngUniques As Range, _
rngTemp As Range, _
rngLastTheme As Range, _
Cell As Range, _
i As Long, _
lRow As Long

'// Change to suit //
Const FIRST_DATA_ROW As Long = 4
Const FIRST_THEME_COL As Long = 8

'// Set a reference to the source sheet. //
Set wksData = ThisWorkbook.Worksheets("Intermediate Step")

With wksData

'// Find and set a reference to the cell with the last unique ID //
Set rngTemp = RangeFound(.Range("A:A"))

'// Just in case the sheet is empty, bailout //
If rngTemp Is Nothing Then Exit Sub
If rngTemp.Row < FIRST_DATA_ROW Then Exit Sub

'// Set a reference to all the cells w/the IDs //
Set rngUniques = Range(.Cells(FIRST_DATA_ROW, "A"), rngTemp)

'// Create a referenced destination sheet //
Set wksOutput = ThisWorkbook.Worksheets.Add(After:=wksData, Type:=xlWorksheet)

'// Copy over the header area //
Range(.Cells(1), .Cells(FIRST_DATA_ROW - 1, FIRST_THEME_COL)).Copy wksOutput.Cells(1)

'// Duplicate column widths from source to destination //
For Each Cell In rngUniques.Cells(1).Resize(, FIRST_THEME_COL)
wksOutput.Cells(1, Cell.Column).ColumnWidth = Cell.ColumnWidth
Next

'// For each record... //
For Each Cell In rngUniques

'// Find the last column w/data, ie - the last emerging themes //
Set rngTemp = RangeFound(SearchRange:=Range(.Cells(Cell.Row, 1), _
.Cells(Cell.Row, .Columns.Count)), _
SearchRowCol:=xlByColumns)

'// From first to last emerging theme... //
For i = FIRST_THEME_COL To rngTemp.Column
'// ...find the next blank row in destination sheet and copy/paste. //
lRow = wksOutput.Cells(wksOutput.Rows.Count, 1).End(xlUp).Offset(1).Row
Cell.Resize(, FIRST_THEME_COL - 1).Copy wksOutput.Cells(lRow, 1)
Cell.Offset(, i - 1).Copy wksOutput.Cells(lRow, FIRST_THEME_COL)
Next
Next
End With
End Sub

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function

In answer to your last question, as Shrivallabha mentioned, members help each other in their 'spare' time (whatever that is), so certainly while you may have a question best suited to a particular person, oft you may receive a faster answer by just posting the question and seeing if you get any 'bites'.

Hope that helps and again, welcome here :-)

Mark

[monkeydt]

Hi Mark, I apologies if I seemed impatient, I wasn't...I appreciate everyones effort in this. I'm such a basic novice, and get frustrated at my own incompetencies in this area!

Again, a massive thank you to all that helped.

[GTO]

Hi Mark, I apologies if I seemed impatient, I wasn't...

Gosh, when I joined, I nearly pestered someone to death by being overly anxious and wanting to learn. No worries whatsoever, you did not seem impatient, just like a new member:thumb.

[monkeydt]

Hiya, How can I adjust shrivallabha code as I have to add in two columns (at B and F) see attached.

Any help would be great!