Converting imported data to columnular data

All -

I have another issue. I run a report on a weekly basis that exports into Excel and it's been requested that specific data items be listed in columns where it imported not in columns. The data we receive can be anywhere from a few lines long, to several hundred or thousand lines long.

I'm thinking that a macro could handle it, but I've tried doing it and can't get it do do anything close to being right. I've attached a spreadsheet that contains a sample of the data we're trying to reformat, and there's a tab within that shows what we're trying to accomplish.

Would anyone have any pointers of how to accomplish this feat?

Thanks!
Nick S.

Nick

Here's a start. You will have to make sure the headings on the output sheet are exactly the same as the input sheet with the exception of the trailing ":" or ": ". I've remove these from the source data in column A.

I've also left the category comments pretty much blank except for the item that has that heading in column A. I can't seem to work out consistently if the comments are in the next line from the heading (column D) for all items, or some sort of ad hoc approach. Please clarify.

Sub aaa()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Desired Result")
  Sheets("Sample Data").Activate
  Range("A:A").Replace what:=": ", replacement:=""
  Range("A:A").Replace what:=":", replacement:=""
  For i = 40 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 1).Value = "Contact Date/Time" Then
      outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    End If
    
    Select Case Cells(i, 1).Value
      Case "Contact Date/Time"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 4).Value
        outcol = WorksheetFunction.Match("DNIS", OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 8).Value
      Case "Agent"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 4).Value
      Case "Reviewed By"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 4).Value
      Case "Evaluation Form"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 4).Value
        
      Case "Professional Manner"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
      Case "Category Comments"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 5).Value
      Case "Agent Solution Number and Name"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
      Case "Customer E-mail"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
      Case "Alertness"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
      Case "Asks Pertinent Questions"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
      Case "Offer Choices and Information"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        
      Case "Avoids Inside Jargon"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
      Case "Expresses Gratitude"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
      Case "Level Set"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
      Case "Overall Professionalism"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
      Case "Contact Score"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
    End Select
  

  Next i
  
  
End Sub

rylo

Rylo -

Thanks for your help thus far, As for the comments, what I do know is that on the exported report (the Recovered_Sheet1 tab) the comments only show if there are comments present, which is why I added the comments section after each item, just to be safe.

It would appear that in each case from what I can see, the comments for each section appear on the row just above the next section. For example, in the attached sheet, the comments for the section "Agent Solution Number and Name" appear in the row directly above "Customer E-mail" and falls on the same line as the comments label.

I've added a new workbook that is exactly as I receive it in the export with your code, and a little bit of my own at the beginning to set up the "Final Destination" sheet I will be working with.

I really appreciate your help as this stuff to me is pretty advanced VBA and I'm still trying to learn it.

Hi

The comments seem to be 3 lines below the item. Try this (I've had to split the code over 2 posts due to the size).

Sub EvalReporterExportFormat()
    Sheets("Recovered_Sheet1").Select
    Sheets.Add
    Sheets("Sheet1").Select
    Sheets("Sheet1").Move after:=Sheets(2)
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "Data"
    Sheets("Recovered_Sheet1").Select
    Sheets("Recovered_Sheet1").Name = "Exported"
    Sheets("Data").Select
    ActiveCell.FormulaR1C1 = "Contact Date/Time"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Agent"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Reviewed By"
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Evaluation Form"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "DNIS"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Notes"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Professional Manner"
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "Category Comments"
    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Agent Solution Number and Name"
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Category Comments"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "Customer E-mail"
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "Category Comments"
    Range("M1").Select
    ActiveCell.FormulaR1C1 = "Alertness"
    Range("N1").Select
    ActiveCell.FormulaR1C1 = "Category Comments"
    Range("O1").Select
    ActiveCell.FormulaR1C1 = "Asks Pertinent Questions"
    Range("P1").Select
    ActiveCell.FormulaR1C1 = "Category Comments"
    Range("Q1").Select
    ActiveCell.FormulaR1C1 = "Offer Choices and Information"
    Range("R1").Select
    ActiveCell.FormulaR1C1 = "Category comments"
    Range("R1").Select
    ActiveCell.FormulaR1C1 = "Category Comments"
    Range("S1").Select
    ActiveCell.FormulaR1C1 = "Avoids Inside Jargon"
    Range("T1").Select
    ActiveCell.FormulaR1C1 = "Expresses Gratitude"
    Range("U1").Select
    ActiveCell.FormulaR1C1 = "Category Comments"
    Range("V1").Select
    ActiveCell.FormulaR1C1 = "Level Set"
    Range("W1").Select
    ActiveCell.FormulaR1C1 = "Category Comments"
    Range("X1").Select
    ActiveCell.FormulaR1C1 = "Overall Professionalism"
    Range("Y1").Select
    ActiveCell.FormulaR1C1 = "Category comments"
    Range("Z1").Select
    ActiveCell.FormulaR1C1 = "Contact Score"
    Range("AA1").Select
    ActiveCell.FormulaR1C1 = "Contact Comments"
    Cells.Select
    With Selection.Font
        .Name = "MS Sans Serif"
        .Size = 8.5
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
    End With
    Rows("1:1").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Font.Bold = True
    Selection.Font.Underline = xlUnderlineStyleSingle
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.Select
    With Selection
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    Columns("A:A").Select
    Selection.ColumnWidth = 18
    Columns("B:B").Select
    Selection.ColumnWidth = 15
    Columns("C:C").Select
    Selection.ColumnWidth = 15
    Columns("D:D").Select
    Selection.ColumnWidth = 14
    Columns("E:E").Select
    Selection.ColumnWidth = 4
    Selection.ColumnWidth = 5
    Columns("F:F").Select
    Selection.ColumnWidth = 13
    Columns("G:G").Select
    Selection.ColumnWidth = 11
    Columns("H:H").Select
    Selection.ColumnWidth = 20
    Columns("I:I").Select
    Selection.ColumnWidth = 11
    Columns("J:J").Select
    Selection.ColumnWidth = 20
    Columns("K:K").Select
    Selection.ColumnWidth = 8
    Columns("L:L").Select
    Selection.ColumnWidth = 20
    Columns("M:M").Select
    Selection.ColumnWidth = 8
    Columns("N:N").Select
    Selection.ColumnWidth = 20
    Columns("O:O").Select
    Selection.ColumnWidth = 10
    Columns("P:P").Select
    Selection.ColumnWidth = 20
    Columns("Q:Q").Select
    Selection.ColumnWidth = 10
    Columns("R:R").Select
    Selection.ColumnWidth = 20
    Columns("S:S").Select
    Selection.ColumnWidth = 8
    Columns("T:T").Select
    Selection.Insert Shift:=xlToRight
    Range("T1").Select
    ActiveCell.FormulaR1C1 = "Category Comments"
    With ActiveCell.Characters(Start:=1, Length:=17).Font
        .Name = "MS Sans Serif"
        .FontStyle = "Bold"
        .Size = 8.5
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleSingle
        .ColorIndex = 1
    End With
    Columns("T:T").Select
    Selection.ColumnWidth = 20
    Columns("U:U").Select
    Selection.ColumnWidth = 10
    Columns("V:V").Select
    Selection.ColumnWidth = 20
    Columns("W:W").Select
    Selection.ColumnWidth = 8
    Columns("X:X").Select
    Selection.ColumnWidth = 20
    Columns("Y:Y").Select
    Selection.ColumnWidth = 14
    Columns("Z:Z").Select
    Selection.ColumnWidth = 20
    ActiveWindow.ScrollColumn = 17
    Columns("AA:AA").Select
    Selection.ColumnWidth = 8
    Columns("AB:AB").Select
    Selection.ColumnWidth = 20
    Range("G2").Select
    ActiveWindow.FreezePanes = True
    Range("A1").Select

Next part. I've repeated the last line from the previous block so you can be sure of the join.

Range("A1").Select

    
      Dim OutSH As Worksheet
  Set OutSH = Sheets("Data")
  Sheets("Exported").Activate
  Range("A:A").Replace what:=": ", replacement:=""
  Range("A:A").Replace what:=":", replacement:=""
  For i = 40 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 1).Value = "Contact Date/Time" Then
      outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    End If
    
    Select Case Cells(i, 1).Value
      Case "Contact Date/Time"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 4).Value
        outcol = WorksheetFunction.Match("DNIS", OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 8).Value
      Case "Agent"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 4).Value
      Case "Reviewed By"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 4).Value
      Case "Evaluation Form"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 4).Value
        
      Case "Professional Manner"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
      'Case "Category Comments"
        'outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        'OutSH.Cells(outrow, outcol).Value = Cells(i, 5).Value
      Case "Agent Solution Number and Name"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
      Case "Customer E-mail"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
      Case "Alertness"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
      Case "Asks Pertinent Questions"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
      Case "Offer Choices and Information"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
        
      Case "Avoids Inside Jargon"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
      Case "Expresses Gratitude"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
      Case "Level Set"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
      Case "Overall Professionalism"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
      Case "Contact Score"
        outcol = WorksheetFunction.Match(Cells(i, 1).Value, OutSH.Rows("1:1"), 0)
        OutSH.Cells(outrow, outcol).Value = Cells(i, 11).Value
        If Cells(i + 3, 1).Value = "Category Comments" Then
          OutSH.Cells(outrow, outcol + 1).Value = Cells(i + 3, 5).Value
        End If
    End Select
  

  Next i
  
End Sub

rylo

Rylo -

This works great! Thanks so much for your help. The only other question I have is how to get the notes (first occurrence is in row 44, column H) to populate into the reformatted worksheet. I've tried looking at your code to see if there's any way I can make it move over on my own, but I really don't understand the code you have.

I've added a new workbook with your code as it works now.