☰

Excel で複数の列をグループ化して転置する

tag-icon • tag-icon microsoft-excel transpose
Excel で複数の列をグループ化して転置する

企業、支店、企業データ、連絡先が満載の Excel シートがあります。

元のExcelデータ

同じ会社と支店の都市のデータをグループ化し、転置して、各列に会社/支店のヘッダー情報、連絡先 1、連絡先 2、連絡先 3 などが含まれるようにしたいと考えています。次の列には、次の会社/支店のヘッダー情報、その連絡先が含まれます。各連絡先には、名と姓、および連結された役職があり、名と姓で並べ替えられる必要があります。

希望フォーマット

データは頻繁に変更されるため、特定のデータ (最初のショット) に対してこれを定期的に実行したいと思います。これは、数式、VBA、ピボット テーブルを使用して行うのが最適ですか? ご協力いただければ幸いです。

編集
以下に、Ron の洗練されたソリューションの手順をすべて追加します。
1. ワークシートをマクロ対応 (.xlsm) ワークシートに保存します。
2. メイン シートの名前が sheet1 であることを確認します。
3. sheet2 という空のターゲット シートを作成します。
4. VBA エディターを開きます (Alt + F11)。
5. [挿入]、[クラス モジュール] の順にクリックし、クラス モジュール コードを貼り付けます
。 6. F4 キーを押してクラス モジュールのプロパティ ウィンドウを表示し、[名前] フィールドで cCompanyInfo に変更します
。 7. [挿入]、[モジュール] の順にクリックし、標準モジュール コードを貼り付けます
。 8. [ツール]、[参照設定] の順にクリックし、[Microsoft Scripting Runtime] を見つけてチェック ボックスをオンにして [OK] をクリックします
。 9. ワークシートに戻り、Alt + F8 キーを押してマクロを表示し、[実行] をクリックします。

sheet2 には書式設定されたデータが書き込まれます。

[マクロの表示] ダイアログの [オプション] ボタンを使用して、マクロを実行するキーボード ショートカットを割り当てることもできます。

答え1

  • マクロを記録し、マクロホットキーを割り当ててタスクを実行します
  • コピー > 特殊貼り付け > 転置 > カーソルを配置 [Enter]
  • テキストを次のように連結します。ジョー・ブロウ、最高責任者数式付き
  • =M5＆「」＆M6＆"、"＆M7
    • これらのセルには4つのエントリが含まれています。二重引用符にはスペースとカンマが含まれています。

答え2

元のデータにいくつか変更を加えました。

ABC Corp.具体的には、順序が間違っており、Note他のエントリとは 異なる最後の行を追加しました。

コーディングでそれがどのように処理されるかを確認でき、必要に応じて、異なる電話番号がある場合にも同様の手法を使用できます。

電話番号については、数値以外の要素を削除して、入力が一貫していない場合にすべて一貫した形式で表示できるようにしました。実際のデータの変動性に応じて、このアルゴリズムを変更する必要がある場合があります。

結果が「見栄え良く」なるように、いくつかの書式設定を行いました。書式設定をまったく行わないか、別の書式設定を希望されるかもしれません。また、通常のモジュールでワークシート名を調整する必要もあるかもしれません。

将来的にこれを維持できるように、コードとメモを必ず読んで理解してください。

オリジナルデータ:

ここに画像の説明を入力してください

クラスモジュール

必ず名前を変更してください会社情報

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

通常モジュール

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

結果:

ここに画像の説明を入力してください

関連情報