I have an Excel sheet full of companies, branches, company data and contacts.

Original Excel Data

I'm trying to group the data on the same company and branch city, then transpose, so that in each single column I have Company/Branch header info, then contact1, contact2, contact3, etc. Then, next column, the next Company/Branch header info, then its contacts. Each contact should have their first and last names, and titles concatenated, and should be sorted by first, last names.

Desired Format

I'd like to do this regularly for the given data (first shot), as it will change frequently. Is this best done with formulas, VBA, Pivot table? Any help would be appreciated.

Just to add all the steps for Ron's elegant solution below:
1. Save the worksheet to a Macro-enabled (.xlsm) worksheet
2. Make sure the main sheet is called sheet1
3. Create a blank target sheet called sheet2
4. Open the VBA editor (Alt-F11)
5. Click Insert, Class Module, then paste in the Class Module code
6. Press F4 to view the Class Module's property window, then in the Name field, change it to cCompanyInfo
7. Click Insert, Module, then paste in the Regular Module code
8. Click Tools, References, then find Microsoft Scripting Runtime, and check the box and click Ok
9. Back in the worksheet, press Alt-F8 to view the Macro, and click Run.

sheet2 will be filled with the formatted data.

You can also assign a keyboard shortcut to run the macro by using the Options button on the view Macro dialog

  • I would suggest VBA. Sep 18, 2016 at 0:44
  • I'm not a VBA expert. Any ideas on how to do this?
    – VBStarr
    Sep 18, 2016 at 4:51
  • I would use Classes and Collections or Dictionaries to combine the data and create the kind of output you need. There are examples of doing this on SO, but nothing that can be lifted directly and used for your purpose, because of the need for combining the contact information fields into a single field. Sep 18, 2016 at 12:25

2 Answers 2

  • Record a macro, assign a macro hotkey then perform the tasks
  • Copy > paste special > transpose> place cursor [enter]
  • concatenate (&) text like this joe blow, chief honcho with formulae
  • =M5 & " " & M6 &", "&M7
    • where these cells contain the 4 entries. and the double quotes contain the space and comma
  • Your method will result in a vertical column for each row, and the OP shows that he wants to combine rows where company/branch are the same. Sep 18, 2016 at 10:23
  • good point. In a macro it gets messy doing a sort and Vlookup. and smart filter cell pointer increment . Your result looks good. This would be easier in an Access Report Sep 18, 2016 at 15:24

I made a few changes in your original data.

Specifically, I added a last row which has an ABC Corp. but out of order, and also has a different Note than the other entries.

You can see how that is handled in the coding and, if necessary, you could use a similar technique if you also had different phone numbers.

For the phone numbers, I removed the non-numeric elements so they can all be displayed in a consistent format, in case they are not entered consistently. You may need to modify this algorithm, depending on the variability in your real data.

I did some formatting to make the results "look nice". You might prefer none or a different formatting You may also need to adjust worksheet names in the regular module.

Be sure to read and understand the code and notes, in order to be able to maintain this in the future.

Original Data:

enter image description here

Class Module

Be sure to rename this cCompanyInfo

Option Explicit
'Rename this class module:  cCompanyInfo

Const dictKey = 1
Const dictItem = 2

Private pCompany As String
Private pBranch As String
Private pPhone As Currency
Private pNote As String
Private pNotes As Dictionary
Private pFirstName As String
Private pLastName As String
Private pTitle As String
Private pNameTitles As Dictionary

Public Property Get Company() As String
    Company = pCompany
End Property
Public Property Let Company(Value As String)
    pCompany = Value
End Property

Public Property Get Branch() As String
    Branch = pBranch
End Property
Public Property Let Branch(Value As String)
    pBranch = Value
End Property

Public Property Get Phone() As Currency
    Phone = pPhone
End Property
Public Property Let Phone(Value As Currency)
    pPhone = Value
End Property

Public Property Get Note() As String
    Note = pNote
End Property
Public Property Let Note(Value As String)
    pNote = Value
End Property

Public Property Get FirstName() As String
    FirstName = pFirstName
End Property
Public Property Let FirstName(Value As String)
    pFirstName = Value
End Property

Public Property Get LastName() As String
    LastName = pLastName
End Property
Public Property Let LastName(Value As String)
    pLastName = Value
End Property

Public Property Get Title() As String
    Title = pTitle
End Property
Public Property Let Title(Value As String)
    pTitle = Value
End Property

Public Property Get Notes() As Dictionary
    Set Notes = pNotes
End Property
Public Function ADDNote(Value As String)
    If Not pNotes.Exists(Value) Then pNotes.Add Value, Value
End Function

Public Property Get NameTitles() As Dictionary
    Set NameTitles = pNameTitles
End Property
Public Function ADDNameTitle(S As String)
    If Not pNameTitles.Exists(S) Then pNameTitles.Add S, S
End Function

Private Sub Class_Initialize()
    Set pNotes = New Dictionary
    Set pNameTitles = New Dictionary
End Sub

'Dictionary Sort routine
'Shamelessly copied From  https://support.microsoft.com/en-us/kb/246067

Public Sub SortDictionary(objDict, intSort)
  ' declare our variables
  Dim strDict()
  Dim objKey
  Dim strKey, strItem
  Dim X, Y, Z

  ' get the dictionary count
  Z = objDict.Count

  ' we need more than one item to warrant sorting
  If Z > 1 Then
    ' create an array to store dictionary information
    ReDim strDict(Z, 2)
    X = 0
    ' populate the string array
    For Each objKey In objDict
        strDict(X, dictKey) = CStr(objKey)
        strDict(X, dictItem) = CStr(objDict(objKey))
        X = X + 1

    ' perform a a shell sort of the string array
    For X = 0 To (Z - 2)
      For Y = X To (Z - 1)
        If StrComp(strDict(X, intSort), strDict(Y, intSort), vbTextCompare) > 0 Then
            strKey = strDict(X, dictKey)
            strItem = strDict(X, dictItem)
            strDict(X, dictKey) = strDict(Y, dictKey)
            strDict(X, dictItem) = strDict(Y, dictItem)
            strDict(Y, dictKey) = strKey
            strDict(Y, dictItem) = strItem
        End If

    ' erase the contents of the dictionary object

    ' repopulate the dictionary with the sorted information
    For X = 0 To (Z - 1)
      objDict.Add strDict(X, dictKey), strDict(X, dictItem)

  End If

End Sub

Regular Module

Option Explicit
'Set Reference to Microsoft Scripting Runtime

Sub ConsolidateCompanyInfo()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim cCI As cCompanyInfo, dictCI As Dictionary
    Dim sNT As String
    Dim I As Long, J As Long, L As Currency, S As String
    Dim LastRow As Long, LastCol As Long

'Change worksheets names as appropriate
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

'Read the data into an array
With wsSrc
    LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    vSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With

'Organize and Collect the data
Set dictCI = New Dictionary
For I = 2 To UBound(vSrc, 1)
    Set cCI = New cCompanyInfo
    With cCI
        .Company = vSrc(I, 1)
        .Branch = vSrc(I, 2)

        'Remove non-numeric characters from phone number for consistency
        'might need to add other Replace functions, or use Regex
        L = Replace(vSrc(I, 3), "-", "")

        .Phone = L
        .Note = vSrc(I, 4)
        .ADDNote .Note
        .FirstName = vSrc(I, 5)
        .LastName = vSrc(I, 6)
        .Title = vSrc(I, 7)
        sNT = .FirstName & " " & .LastName & ", " & .Title
        .ADDNameTitle sNT
        S = .Company & "|" & .Branch
        If Not dictCI.Exists(S) Then
            dictCI.Add S, cCI
            dictCI(S).ADDNote .Note
            dictCI(S).ADDNameTitle sNT
        End If
    End With
Next I

'Populate Results array
Dim V, W
I = 0

'First need to size the sections
Const lHeader As Long = 3 'Name, Branch, Phone number Rows
Dim lNotes As Long
Dim lContacts As Long

For Each V In dictCI
    With dictCI(V)
        lNotes = IIf(lNotes > .Notes.Count, lNotes, .Notes.Count)
        lContacts = IIf(lContacts > .NameTitles.Count, lContacts, .NameTitles.Count)
    End With
Next V

ReDim vRes(1 To lHeader + 1 + lNotes + 1 + lContacts, 1 To dictCI.Count)

J = 0
For Each V In dictCI
    J = J + 1
    With dictCI(V)
        vRes(1, J) = .Company
        vRes(2, J) = .Branch
        vRes(3, J) = .Phone
        I = lHeader + 1

        For Each W In .Notes
            I = I + 1
            vRes(I, J) = .Notes(W)
        Next W

        I = lHeader + 1 + lNotes + 1

        .SortDictionary .NameTitles, 1
        For Each W In .NameTitles
            I = I + 1
            vRes(I, J) = .NameTitles(W)
        Next W
    End With

Next V

'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
    .Value = vRes

    'Do some formatting to pretty things up
    'You could certainly do something different
    Range(.Rows(1), .Rows(lHeader)).Style = "Input"
    Range(.Rows(lHeader + 2), .Rows(lHeader + 1 + lNotes)).Style = "Note"
    Range(.Rows(lHeader + 1 + lNotes + 2), .Rows(lHeader + 1 + lNotes + 1 + lContacts)).Style = "Output"
    With .Rows(3)  'Format the phone number
        .NumberFormat = "000-000-0000"
        .HorizontalAlignment = xlLeft
    End With
End With

End Sub


enter image description here

  • this looks great, and just what I need. Now I just need to figure out how to integrate this all into Excel properly. Any hints/tips on that would be appreciated.
    – VBStarr
    Sep 18, 2016 at 14:39
  • why do you do this when Access wizard is so much easier to create a report view/EXPORT to target app.. I guess as always the best method or tool is ONE you know. Sep 18, 2016 at 15:02
  • @BeachBum Start by doing an Internet Search for "Introduction to VBA" and start getting familiar. Sep 18, 2016 at 16:45
  • @TonyStewart Please provide an answer using your tool of choice. That would help others get familiar with what is available. Sep 18, 2016 at 17:16
  • @BeachBum Glad to see you were able to figure out how to use the solution. If it is providing the desired results, can you please mark my response as the answer? Tks. Sep 21, 2016 at 0:32

You must log in to answer this question.

Not the answer you're looking for? Browse other questions tagged .