Excel agrupa várias colunas e transpõe

Question

Eu tenho uma planilha do Excel cheia de empresas, agências, dados da empresa e contatos.

Estoutentandoagruparosdadosnamesmaempresaecidadedefiliale,emseguida,transpor,paraqueemcadacolunaeutenhainformaçõesdecabeçalhoEmpresa/Filial,entreemcontato1,contato2,contato3,etc.apróximainformaçãodocabeçalhoEmpresa/Filial,depoisseuscontatos.Cadacontatodeveterseusnomesesobrenomesetítulosconcatenados,edeveserclassificadoprimeiro,porsobrenome.

Gostaria de fazer isso regularmente para os dados fornecidos (primeiro disparo), pois ele mudará com frequência. Isso é feito melhor com fórmulas, VBA, tabela dinâmica? Qualquer ajuda seria apreciada.

EDITAR
Apenas para adicionar todos os passos para a solução elegante de Ron abaixo:
1. Salve a planilha em uma planilha habilitada para macro (.xlsm)
2. Verifique se a planilha principal é chamada de planilha1
3. Crie uma folha de destino em branco chamada sheet2
4. Abra o editor do VBA (Alt-F11)
5. Clique em Inserir, módulo de classe e cole no código do módulo de classe. 6. Pressione F4 para exibir a janela de propriedades do Módulo da Classe e, em seguida, no campo Nome, altere para cCompanyInfo
7. Clique em Inserir, Módulo e cole no código do Módulo Regular
8. Clique em Ferramentas, Referências, em seguida, localize o Microsoft Scripting Runtime e marque a caixa e clique em Ok
9. De volta à planilha, pressione Alt-F8 para visualizar a macro e clique em Executar.

sheet2 será preenchido com os dados formatados.

Você também pode atribuir um atalho de teclado para executar a macro usando o botão Opções na caixa de diálogo Exibir macro

    

Answer 1

• Grave uma macro, atribua uma tecla de atalho de macro e execute as tarefas
• Copiar > colar especial > transpor > colocar cursor [enter]
• concatenar (&) texto como este joe blow, chefe honcho com fórmulas
• = M5 & "" & M6 e "," e M7
  • onde essas células contêm as 4 entradas. e as aspas duplas contêm o espaço e a vírgula

Answer 2

Eu fiz algumas alterações em seus dados originais.

Especificamente, adicionei uma última linha que tem um ABC Corp. , mas fora de ordem, e também tem um Note diferente das outras entradas.

Você pode ver como isso é tratado na codificação e, se necessário, você poderia usar uma técnica semelhante se também tivesse números de telefone diferentes.

Para os números de telefone, removi os elementos não numéricos para que todos possam ser exibidos em um formato consistente, caso eles não sejam inseridos de forma consistente. Você pode precisar modificar esse algoritmo, dependendo da variabilidade em seus dados reais.

Eu fiz algumas formatações para tornar os resultados "bonitos". Você pode preferir nenhum ou uma formatação diferente. Você também pode precisar ajustar os nomes da planilha no módulo regular.

Certifique-se de ler e entender o código e as anotações para poder manter isso no futuro.

Dados originais :

Módulodeturma

BesuretorenamethiscCompanyInfo

OptionExplicit'Renamethisclassmodule:cCompanyInfoConstdictKey=1ConstdictItem=2PrivatepCompanyAsStringPrivatepBranchAsStringPrivatepPhoneAsCurrencyPrivatepNoteAsStringPrivatepNotesAsDictionaryPrivatepFirstNameAsStringPrivatepLastNameAsStringPrivatepTitleAsStringPrivatepNameTitlesAsDictionaryPublicPropertyGetCompany()AsStringCompany=pCompanyEndPropertyPublicPropertyLetCompany(ValueAsString)pCompany=ValueEndPropertyPublicPropertyGetBranch()AsStringBranch=pBranchEndPropertyPublicPropertyLetBranch(ValueAsString)pBranch=ValueEndPropertyPublicPropertyGetPhone()AsCurrencyPhone=pPhoneEndPropertyPublicPropertyLetPhone(ValueAsCurrency)pPhone=ValueEndPropertyPublicPropertyGetNote()AsStringNote=pNoteEndPropertyPublicPropertyLetNote(ValueAsString)pNote=ValueEndPropertyPublicPropertyGetFirstName()AsStringFirstName=pFirstNameEndPropertyPublicPropertyLetFirstName(ValueAsString)pFirstName=ValueEndPropertyPublicPropertyGetLastName()AsStringLastName=pLastNameEndPropertyPublicPropertyLetLastName(ValueAsString)pLastName=ValueEndPropertyPublicPropertyGetTitle()AsStringTitle=pTitleEndPropertyPublicPropertyLetTitle(ValueAsString)pTitle=ValueEndPropertyPublicPropertyGetNotes()AsDictionarySetNotes=pNotesEndPropertyPublicFunctionADDNote(ValueAsString)IfNotpNotes.Exists(Value)ThenpNotes.AddValue,ValueEndFunctionPublicPropertyGetNameTitles()AsDictionarySetNameTitles=pNameTitlesEndPropertyPublicFunctionADDNameTitle(SAsString)IfNotpNameTitles.Exists(S)ThenpNameTitles.AddS,SEndFunctionPrivateSubClass_Initialize()SetpNotes=NewDictionarySetpNameTitles=NewDictionaryEndSub'DictionarySortroutine'ShamelesslycopiedFromhttps://support.microsoft.com/en-us/kb/246067PublicSubSortDictionary(objDict,intSort)'declareourvariablesDimstrDict()DimobjKeyDimstrKey,strItemDimX,Y,Z'getthedictionarycountZ=objDict.Count'weneedmorethanoneitemtowarrantsortingIfZ>1Then'createanarraytostoredictionaryinformationReDimstrDict(Z,2)X=0'populatethestringarrayForEachobjKeyInobjDictstrDict(X,dictKey)=CStr(objKey)strDict(X,dictItem)=CStr(objDict(objKey))X=X+1Next'performaashellsortofthestringarrayForX=0To(Z-2)ForY=XTo(Z-1)IfStrComp(strDict(X,intSort),strDict(Y,intSort),vbTextCompare)>0ThenstrKey=strDict(X,dictKey)strItem=strDict(X,dictItem)strDict(X,dictKey)=strDict(Y,dictKey)strDict(X,dictItem)=strDict(Y,dictItem)strDict(Y,dictKey)=strKeystrDict(Y,dictItem)=strItemEndIfNextNext'erasethecontentsofthedictionaryobjectobjDict.RemoveAll'repopulatethedictionarywiththesortedinformationForX=0To(Z-1)objDict.AddstrDict(X,dictKey),strDict(X,dictItem)NextEndIfEndSub

Móduloregular

OptionExplicit'SetReferencetoMicrosoftScriptingRuntimeSubConsolidateCompanyInfo()DimwsSrcAsWorksheet,wsResAsWorksheet,rResAsRangeDimvSrcAsVariant,vResAsVariantDimcCIAscCompanyInfo,dictCIAsDictionaryDimsNTAsStringDimIAsLong,JAsLong,LAsCurrency,SAsStringDimLastRowAsLong,LastColAsLong'ChangeworksheetsnamesasappropriateSetwsSrc=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

Resultados :