Função Excel: puxando dados usando o intervalo de pesquisa com dados múltiplos e heterogêneos

Question

Estou tentando produzir um relatório em que uma coluna contendo vários dados exclusivos seja usada como identificadores ao extrair dados de uma tabela / banco de dados de origem em que a matriz de pesquisa contém células ou campos que possuem dados repetitivos e heterogêneos.

A ilustração abaixo pode explicar o que estou tentando realizar:

Esta é a tabela de origem

Eorelatórioabaixoéoqueestoutentandorealizar:

Estou tentando encontrar perguntas semelhantes, mas sem sucesso. Eu posso me classificar como usuário intermediário no Excel, especialmente no lado do VBA.

    

Answer 1

Eu tive algum tempo livre, então eu escrevi uma Macro VBA que pode automatizar isso. Desde que você tenha algum conhecimento de VBA, passe por este código e entenda onde quer que exista um pouco de hard coding. A macro faz três coisas

1. Transpor dados da tabela de entrada para a tabela de resultados.
2. Classifique a tabela de saída
3. Mesclar as células de valor duplicadas na primeira coluna. No entanto, sugiro que você comente esta parte do código, para que, no futuro, a aplicação da Tabela Dinâmica à tabela de saída seja simplificada, se necessário.

Neste exemplo, a tabela de Entrada está em A1: C4 (A2: A4 sendo as células do Nome do Produto). A tabela de saída começa na célula E1. Coloque essa codificação rígida no VBA para combinar com seus intervalos de tabela. A folha deve ser nomeada como 'Folha1'. Há codificação rígida para nome da planilha e intervalo de célula de entrada e célula de início de saída no código. Por favor, veja todas as instâncias para o código funcionar corretamente.

Na sua planilha pressione ALT + F11 para abrir o Editor VBA e Inserir um Módulo e cole o código abaixo nele para criar uma Macro chamada Relatório.

Sub Report()
Dim noofrows As Integer
Dim startrow As Integer
Dim startcol As Integer
Dim repstartrow As Integer
Dim repstartcol As Integer
Dim bincode As String
Dim storagecode As String
'Hard Coding below
noofrows = Range("A2:A4").Rows.Count  'Specify the Input Data Range from a Column
startrow = Range("A2").Row
startcol = Range("A2").Column
repstartrow = Range("E1").Row         'Specify Output Data Table's First Cell here
repstartcol = Range("E1").Column

Cells(repstartrow, repstartcol).Value = "Products"
Cells(repstartrow, repstartcol).Font.Bold = True
Cells(repstartrow, repstartcol + 1).Value = "BinCode"
Cells(repstartrow, repstartcol + 1).Font.Bold = True
Cells(repstartrow, repstartcol + 2).Value = "StorageCode"
Cells(repstartrow, repstartcol + 2).Font.Bold = True

repstartrow = repstartrow + 1

For i = 1 To noofrows

   Dim strTest As String
   Dim strArray() As String
   Dim intCount As Integer

   strTest = Cells(startrow, startcol).Value
   strArray = Split(strTest, ";")
   bincode = Cells(startrow, startcol + 1).Value
   storagecode = Cells(startrow, startcol + 2).Value


   For intCount = LBound(strArray) To UBound(strArray)
      Cells(repstartrow, repstartcol).Value = strArray(intCount)
      Cells(repstartrow, repstartcol + 1).Value = bincode
      Cells(repstartrow, repstartcol + 2).Value = storagecode
      repstartrow = repstartrow + 1
   Next intCount
   startrow = startrow + 1

Next i

'Create All Borders to the table
'Hard Coding below
repstartrow1 = Range("E1").Row
repstartcol = Range("E1").Column

repstartrow = repstartrow - 1

Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With

'Auto Fit the Columns
Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Columns.AutoFit

'Sort the range on Product then Bincode & then StorageCode

Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol), Cells(repstartrow, repstartcol)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol + 1), Cells(repstartrow, repstartcol + 1)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol + 2), Cells(repstartrow, repstartcol + 2)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


'Optional - Merge Cells with repeating Values. Simply comment below code if not desired
repstartrow1 = Range("E1").Row + 1
repstartcol = Range("E1").Column

Application.DisplayAlerts = False
For i = repstartrow1 To repstartrow - 1
        For j = i + 1 To repstartrow
            If Cells(i, repstartcol).Value <> Cells(j, repstartcol).Value Then
                Exit For
            End If
        Next
        Range(Cells(i, repstartcol), Cells(j - 1, repstartcol)).Merge
        Range(Cells(i, repstartcol), Cells(j - 1, repstartcol)).VerticalAlignment = xlTop
        i = j - 1
    Next
Range(Cells(repstartrow1 - 1, repstartcol), Cells(repstartrow1 - 1, repstartcol)).Select

Application.DisplayAlerts = True

End Sub

Salve e saia de volta para a planilha. Pressione ALT + F8 para acessar a caixa de diálogo Macro e executar a macro chamada Relatório para obter a tabela de saída desejada. Observe que você não deve executar novamente essa macro novamente e novamente. Só funcionará uma vez. No entanto, você pode limpar a tabela de saída anterior e executar novamente essa macro novamente para recriar a tabela de saída do zero. A macro pode ser melhorada para limpar a tabela anterior como primeiro passo antes de prosseguir.