Excel Transpose Column to Rows Based on Criteria

**lilianphoebs** · 02-10-2011, 02:49 PM

Hi all, I am working on a report for a healthcare organization but could not get my data into the desired format. I'm proficient with Excel but have not worked with macros before, and was wondering if there'a a quick way to learn how to build a macro to transpose column data to rows, based on complete matches in all the other fields.

The current spreadsheet looks something like this:

........A .................B ......................C .......................D
1 ..Name ..........Provider ............ApptDate ........DiagnosisCode
2 Patient, A .....Doctor, B ..........01/01/10 .............123.45
3 Patient, A .....Doctor, B ..........01/01/10 .............125.11
4 Patient, A .....Doctor, B ..........02/12/10 .............125.11
5 Patient, A .....Nurse, C ...........03/22/10 .............145.6
6 Patient, D .....Doctor, F...........01/04/10 ..............325.1

I would like to transpose Column D when ALL the other fields ( A B C ) match.

In this example, the data should come out looking like this:

.........A ...............B ...............C ..............D .................E...................F.............G...
1 ...Name .......Provider .....ApptDate... Diagnosis1 ...Diagnosis2....Diagnosis3...
2 Patient, A ...Doctor, B ....01/01/10 ......123.45 ............125.11
4 Patient, A ...Doctor, B ....02/12/10 ......125.11...
5 Patient, A ...Nurse, C .....03/22/10 ......145.6....
6 Patient, D ...Doctor, F ....01/04/10.......325.1.....

A sample worksheet with actual header names is attached.

Thank you so much for all your help!

**rylo** · 02-10-2011, 08:54 PM

Hi

See how this goes.

Sub aaa()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Sheet2")
  OutSH.Range("A1:I1").Value = Sheets("Sheet1").Range("A1:I1").Value
  Sheets("Sheet1").Activate
  maxcol = 9
  For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    holder = ""
    For j = 1 To 8
      holder = holder & Cells(i, j).Value & "|"
    Next j
    holder = Left(holder, Len(holder) - 1)
    Set findit = OutSH.Range("A:A").Find(what:=holder)
    If findit Is Nothing Then
      OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = holder
      Set findit = OutSH.Range("A:A").Find(what:=holder)
    End If
    OutSH.Cells(findit.Row, WorksheetFunction.Max(9, OutSH.Cells(findit.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Column)).Value = Cells(i, "I").Value
    curcol = OutSH.Cells(findit.Row, Columns.Count).End(xlToLeft).Column
    If curcol > maxcol Then maxcol = curcol
  Next i
  OutSH.Activate
    Range(Range("A2"), Range("A2").End(xlDown)).Select
    Selection.TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
  For i = 9 To maxcol
    Cells(1, i).Value = Cells(1, 9).Value
  Next i
  
End Sub

rylo

**lilianphoebs** · 02-14-2011, 10:49 AM

Thank you so much! Got the job done.
It is giving me an error 400 after I run and not auto-performing the text-to-columns, but that's something I could handle manually.