
Tenho uma planilha Excel cheia de empresas, filiais, dados de empresas e contatos.
Estou tentando agrupar os dados na mesma empresa e cidade da filial, depois transpor, para que em cada coluna eu tenha as informações do cabeçalho da Empresa/Filial, depois contato1, contato2, contato3, etc. /Informações do cabeçalho da filial e, em seguida, seus contatos. Cada contato deve ter seu nome, sobrenome e títulos concatenados e deve ser classificado por nome e sobrenome.
Gostaria de fazer isso regularmente para os dados fornecidos (primeira foto), pois eles mudam com frequência. Isso é melhor feito com fórmulas, VBA, tabela dinâmica? Qualquer ajuda seria apreciada.
EDITAR
Apenas para adicionar todas as etapas para a solução elegante de Ron abaixo:
1. Salve a planilha em uma planilha habilitada para macro (.xlsm)
2. Certifique-se de que a planilha principal seja chamada de planilha1
3. Crie uma planilha de destino em branco chamada planilha2
4. Abra o Editor VBA (Alt-F11)
5. Clique em Inserir, Módulo de Classe e cole o código do Módulo de Classe
6. Pressione F4 para visualizar a janela de propriedades do Módulo de Classe e, no campo Nome, altere-o para cCompanyInfo
7. Clique em Inserir, Módulo e cole o código do Módulo Regular
8. Clique em Ferramentas, Referências, encontre Microsoft Scripting Runtime, 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 Visualizar Macro
Responder1
- Grave uma macro, atribua uma tecla de atalho de macro e execute as tarefas
- Copiar> colar especial> transpor> posicionar cursor [enter]
- concatenar (&) texto como esteJoe Blow, chefe de honracom fórmulas
- =M5&" "&M6&","&M7
- onde essas células contêm as 4 entradas. e as aspas duplas contêm espaço e vírgula
Responder2
Fiz algumas alterações em seus dados originais.
Especificamente, adicionei uma última linha que possui um ABC Corp.
mas fora de ordem e também diferente Note
das outras entradas.
Você pode ver como isso é tratado na codificação e, se necessário, pode usar uma técnica semelhante se também tiver 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 não sejam inseridos de forma consistente. Pode ser necessário modificar esse algoritmo, dependendo da variabilidade dos seus dados reais.
Fiz algumas formatações para deixar os resultados "bonitos". Você pode preferir nenhuma ou uma formatação diferente. Você também pode precisar ajustar os nomes das planilhas no módulo normal.
Certifique-se de ler e compreender o código e as notas para poder mantê-los no futuro.
Dados Originais:
Módulo de aula
Certifique-se de renomear issocInformações da Empresa
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
Módulo Regular
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
Resultados: