Solved: Transposing Irregular Data

[abbab]

Hello,

I am trying to create a history table with call center data that we get weekly and need some help. The way I receive the data is how it is set up in column A of the "Data" worksheet in the attached sample (column B just dictates where to find it in the "Results" worksheet). I need to transpose the data (and I am assuming the only way to do this that isn't manual is by using some type of VBA loop) so it appears how it is set up in the "Results" worksheet.

One thing to note: the caller types change week to week (some week there could be only one caller type, the next several), so the length of raw data I get will vary. (I think) I need a code that says (in English) something like "starting at the row after the row with the cell that contains 'items)' on the right, select the following cell and paste it 7 times, then select the next 8 cells and transpose them next to that until you reach the cell containing 'total', skip those seven cells, then start again." Of course, I am new to VBA and that could be totally wrong, since I have been trying something like that and it hasn't worked.

Like I said, I have not been able to figure out how to do this, and am a VBA novice, so any help you can provide (with an explanation of what you're doing so I can learn is nice, too) would be beyond appreciated.

Thanks in advance with your assistance!!
Amy

[SamT]

abbab,

Let me try to rephrase your description of the data. Please correct me if I'm worng.

The Data sheet description:

There are no empty rows within the Data.
All the Data is in Column "A".
The data consists of any number of Record Sets.
Each Record Set can be recognized by a Row, ("line" in your description,) that starts with the words "Caller Type."
The next Row contains the Record Set Type Name.
A Record Set can contain any number of Records.
The Next Row contains the individual Record serial number, which is always incremented by 1 in each Record Set.
The next (,constant number,) 11 Rows contain the individual record Fields of each Record in the Set.
Each individual Record in a Set consists of 12 Rows.
No Record Field value will be larger than the Record Serial number.
Each Record Set is terminated by a Row containing the word "Total."The Results sheet, (Table,) description:

The first Record will be in Row 3
The first field, (Column "A",) will contain the Record Set Type Name.
The Second Field, (Column "B",) will contain the individual Record Serial Number.
The next 11 fields, (constant,) Columns "C" to "M",) will contain the record values.

[abbab]

Hi Sam,
Thanks for getting back to me! I think you got all of the points of the data in your bulleted list above. Any ideas?
Thanks again,
Amy

[GTO]

Greetings Amy,

Here is a try, commented as you asked for. I am presuming that you get new workbooks with teh raw data, so this is with the thought of keeping the code in a seperate workbook. You would need the workbook with the code and the workbook with the data both open, and the workbook with the data selected when you run the code.

In a Standard Module:

Option Explicit

Sub Example_TransposeBits()
Dim wks As Worksheet
Dim wks2 As Worksheet

Dim arrRange As Variant
Dim FoundCell As Range
Dim SearchRange As Range
Dim rngTemp As Range

Dim bolToggle As Boolean

Dim SearchTerms(-1 To 0) As String
Dim SearchTerm As String
Dim arrTemp As Variant

Dim n As Long
Dim i As Long
Dim lSerial As Long
Dim lIndex As Long
Dim lRow As Long

'// With the workbook containing the data selected, start the macro. Select any //
'// cell on the sheet with the data. As we are using .Parent, we'll set a reference//
'// to the worksheet. The Resume Next is in case we cancel the Input Box, as this //
'// will cause and error. //
On Error Resume Next
Set wks = Application.InputBox(Prompt:="Select any cell on the sheet the data is on.", _
Title:=vbNullString, _
Type:=8&).Parent
On Error GoTo 0

'// Bail out if nothing selected. //
If wks Is Nothing Then Exit Sub

'// Initially size our variant array (which will be sub-typed to range objects). //
ReDim arrRange(1 To 2, 0 To 0)

'// Find the last cell in column A with any data. //
Set FoundCell = RangeFound(wks.Range("A:A"))

'// Store our two terms we can search for as range markers (I hope). //
SearchTerms(-1) = "Total"
SearchTerms(0) = "Caller Type:"

'// In case an empty sheet, another 'safety'. //
If Not FoundCell Is Nothing Then

'// Size our search range from cell A1 to the last cell w/data. //
Set SearchRange = wks.Range(wks.Range("A1"), FoundCell)

Do
'// We'll be toggling this boolean. Since it starts (default) as False, //
'// we'll resize the array on the first loop, and every other loop //
'// thereafter. //
If Not bolToggle Then
ReDim Preserve arrRange(1 To 2, 1 To UBound(arrRange, 2) + 1)
End If

'// toggle our flag //
bolToggle = Not bolToggle

'// Choose one of the twi search terms to look for (False = 0, True = -1). //
SearchTerm = SearchTerms(bolToggle)

Set FoundCell = Nothing

'// Running up from the bottom of the current search range, find the term //
'// currently being looked for. //
Set FoundCell = RangeFound(SearchRange, SearchTerm)

'// If not found, we're done and the last elements in the array are empty, //
'// so trim the array. //
If FoundCell Is Nothing Then
If UBound(arrRange, 2) > 1 Then
ReDim Preserve arrRange(1 To 2, 1 To UBound(arrRange, 2) - 1)
End If
Else '// Else we found the current search term, so resize the search range//
'// (reducing it), and store the cell (range) in our array. //
Set SearchRange = wks.Range(wks.Range("A1"), FoundCell)
Set arrRange(2 + bolToggle, UBound(arrRange, 2)) = FoundCell
End If
Loop While Not FoundCell Is Nothing '// Loop until we run out of stuff to find //

'// Create a new sheet to flip the data to. //
Set wks2 = wks.Parent.Worksheets.Add(After:=wks, Type:=xlWorksheet)

'// Since we searched from bottom up, loop "backwards" to keep stuff in order. //
For n = UBound(arrRange, 2) To 1 Step -1

'// Set reference to a range starting one cell below 'Caller type' and one //
'// cell above 'Total' //
Set rngTemp = wks.Range(arrRange(2, n).Offset(1), arrRange(1, n).Offset(-1))

'// Store the initail 'serial' number. //
lSerial = rngTemp.Cells(2, 1).Value

'// Initial value, see a few lines down. //
lIndex = 2

'// rngTemp starts at 'General public/stakeholder by example, so we can start//
'// at row three to start looking for the next serial number. //
For i = 3 To rngTemp.Cells.Count
If rngTemp.Cells(i, 1).Value = lSerial + 1 Then
'// When we find the next Serial number, adjust what number to look //
'// for... //
lSerial = lSerial + 1
'// ...flip the values into an array (transposed)... //
arrTemp = _
Application.Transpose(Range(rngTemp.Cells(lIndex, 1), _
rngTemp(i - 1, 1)).Value _
)
'// ...adjust our index... //
lIndex = i
'// ...find the first empty row in our new sheet... //
lRow = wks2.Cells(wks2.Rows.Count, 1).End(xlUp).Offset(1).Row
'// ...and plunk in the values. //
wks2.Cells(lRow, 1).Value = rngTemp.Cells(1, 1).Value
wks2.Cells(lRow, 2).Resize(, UBound(arrTemp)).Value = arrTemp
End If
Next

'// When we fail to find more serial numbers for this range, we'll have one //
'// range left. Grab those values. //
arrTemp = Application.Transpose(Range(rngTemp(lIndex, 1), _
rngTemp(rngTemp.Cells.Count, 1)).Value)
lRow = wks2.Cells(wks2.Rows.Count, 1).End(xlUp).Offset(1).Row
wks2.Cells(lRow, 1).Value = rngTemp.Cells(1, 1).Value
wks2.Cells(lRow, 2).Resize(, UBound(arrTemp)).Value = arrTemp
Next

wks2.UsedRange.Columns(1).AutoFit
End If
End Sub

Function RangeFound(SearchRange As Range, _
Optional ByVal 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

See the attached and hope that helps :)

Mark

[snb]

An alternative approach:

Sub M_snb()
sn = Split(Join(Application.Transpose(Sheets("Data").Cells(1).CurrentRegion.Resize(, 1)), vbLf), "Caller")

For j = 1 To UBound(sn)
sp = Filter(Split(Split(sn(j), "Total")(0), vbLf), ":", False)
sq = Cells(500, 1).Resize(UBound(sp) \ 12, 13)

For jj = 1 To UBound(sp) - 1
If (jj - 1) Mod 12 = 0 Then sq((jj - 1) \ 12 + 1, 1) = sp(0)
sq((jj - 1) \ 12 + 1, (jj - 1) Mod 12 + 2) = sp(jj)
Next

Sheets("results").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sq), UBound(sq, 2)) = sq
Next
End Sub

[abbab]

Wow, thanks guys!! I am going to try these approaches and will likely be in touch with questions on getting them to work!
Thanks again, really appreciate the input!

[abbab]

Mark, this works amazingly. I can't thank you enough!

[GTO]

:beerchug: You and most welcome and thank you for the feedback.

Mark