Excel gruppiert mehrere Spalten und transponiert

Question

Ich habe eine Excel-Tabelle voller Firmen, Niederlassungen, Firmendaten und Ansprechpartner.

Ich versuche, die Daten nach derselben Firma und Zweigstelle zu gruppieren und dann zu transponieren, sodass ich in jeder einzelnen Spalte die Kopfzeileninformationen zu Firma/Zweigstelle habe, dann Kontakt1, Kontakt2, Kontakt3 usw. Dann die nächste Spalte, die nächsten Kopfzeileninformationen zu Firma/Zweigstelle, dann deren Kontakte. Jeder Kontakt sollte Vor- und Nachnamen sowie Titel aneinandergereiht haben und nach Vor- und Nachnamen sortiert sein.

Ich möchte dies regelmäßig für die angegebenen Daten tun (erster Versuch), da sie sich häufig ändern werden. Geht das am besten mit Formeln, VBA, Pivot-Tabelle? Jede Hilfe wäre willkommen.

BEARBEITEN
Ich füge einfach alle Schritte für Rons elegante Lösung unten hinzu:
1. Speichern Sie das Arbeitsblatt als makrofähiges Arbeitsblatt (.xlsm).
2. Stellen Sie sicher, dass das Hauptblatt „sheet1“ heißt.
3. Erstellen Sie ein leeres Zielblatt namens „sheet2“.
4. Öffnen Sie den VBA-Editor (Alt-F11).
5. Klicken Sie auf „Einfügen“, „Klassenmodul“ und fügen Sie den Code des Klassenmoduls ein
. 6. Drücken Sie F4, um das Eigenschaftenfenster des Klassenmoduls anzuzeigen, und ändern Sie den Namen im Feld „Name“ in „cCompanyInfo“.
7. Klicken Sie auf „Einfügen“, „Modul“ und fügen Sie den Code des regulären Moduls ein
. 8. Klicken Sie auf „Extras“, „Verweise“, suchen Sie nach „Microsoft Scripting Runtime“, aktivieren Sie das Kontrollkästchen und klicken Sie auf „OK“
. 9. Drücken Sie im Arbeitsblatt Alt-F8, um das Makro anzuzeigen, und klicken Sie auf „Ausführen“. „

sheet2“ wird mit den formatierten Daten ausgefüllt.

Sie können auch eine Tastenkombination zum Ausführen des Makros zuweisen, indem Sie die Schaltfläche „Optionen“ im Dialogfeld „Makro anzeigen“ verwenden.

Answer 1

• Zeichnen Sie ein Makro auf, weisen Sie einen Makro-Hotkey zu und führen Sie dann die Aufgaben aus
• Kopieren > Inhalte einfügen > Transponieren > Cursor platzieren [Eingabe]
• Verketten (&) Sie Text wie folgtJoe Blow, Oberbossmit Formeln
• =BMW M5und" "undM6und", "undM7
  • wobei diese Zellen die 4 Einträge enthalten. und die Anführungszeichen enthalten das Leerzeichen und das Komma

Answer 2

Ich habe ein paar Änderungen an Ihren Originaldaten vorgenommen.

Insbesondere habe ich eine letzte Zeile hinzugefügt, die ein „ ABC Corp.aber“ in der falschen Reihenfolge enthält und außerdem ein „anderes“ Noteals die anderen Einträge hat.

Wie das gehandhabt wird, können Sie der Kodierung entnehmen und bei Bedarf eine ähnliche Technik anwenden, wenn Sie auch unterschiedliche Telefonnummern hätten.

Bei den Telefonnummern habe ich die nicht numerischen Elemente entfernt, damit sie alle in einem einheitlichen Format angezeigt werden können, falls sie nicht einheitlich eingegeben werden. Je nach Variabilität Ihrer realen Daten müssen Sie diesen Algorithmus möglicherweise ändern.

Ich habe einige Formatierungen vorgenommen, damit die Ergebnisse "schön aussehen". Sie bevorzugen vielleicht keine oder eine andere Formatierung. Möglicherweise müssen Sie auch die Arbeitsblattnamen im regulären Modul anpassen.

Lesen und verstehen Sie unbedingt den Code und die Hinweise, um diese auch in Zukunft pflegen zu können.

Originale Daten:

Klassenmodul

Benennen Sie dies unbedingt umcFirmeninfo

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
    Next

    ' 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
      Next
    Next

    ' erase the contents of the dictionary object
    objDict.RemoveAll

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

  End If

End Sub

Reguläres Modul

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
        Else
            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
    .EntireColumn.Clear
    .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
    .EntireColumn.AutoFit
End With

End Sub

Ergebnisse: