2

Como eu faria no excel para expandir uma lista enorme com dados para ao invés de agrupar dados de valores, ele mostrasse o conteúdo no total. Exemplo:

Gostaria de transformar isso:

inserir a descrição da imagem aqui

Nisso:

inserir a descrição da imagem aqui

Lembrando que será uma lista enorme de valores. Então algo automatizado ajudaria muito.

4
  • A planilha inicial terá sempre esse mesmo padrão?
    – Evert
    Commented 14/09/2017 às 18:45
  • @Evert A ideia é ter essa mesma estrutura. O que no máximo poderia ser diferente é que ao invés de ser "1 a 10", poderia ser "1-10" ou coisa parecida. Mas toda a coluna seguirá a mesma lógica. Commented 15/09/2017 às 11:14
  • Certo, vamos precisar de um VBA para fazer isso... vou tentar postar algo aqui para te ajudar e veja se consegue colocar em produção ai.
    – Evert
    Commented 15/09/2017 às 11:15
  • @Evert Muito obrigado! Commented 15/09/2017 às 11:17

2 Respostas 2

3

Minha sugestão é a seguinte:

  1. Criar um código para buscar os números da célula, conforme segue abaixo:

    Function Extrair_Numero(ByRef TEXTO As String, _
                            Optional ByRef SEQUENCIAL As Integer = 1) As Double
    Dim i As Integer
    Dim COUNT As Integer
    Dim TEMP As String
    Dim RESULTADO As Double
    
        For i = 1 To Len(TEXTO)
    
            TEMP = Mid(TEXTO, i, 1)
    
            If IsNumeric(TEMP) Then
                RESULTADO = RESULTADO & TEMP
            ElseIf RESULTADO > 0 Then
                COUNT = COUNT + 1
                If RESULTADO > 0 And SEQUENCIAL = COUNT Then
                    Extrair_Numero = CDbl(RESULTADO)
                    Exit Function
                ElseIf COUNT > 0 And SEQUENCIAL > COUNT Then
                    RESULTADO = Empty
                End If
            End If
    
        Next
        Extrair_Numero = CDbl(RESULTADO)
    End Function
    

Esta é uma função que retorna o número a partir de uma string, podendo retornar o número em determinada posição, ou sequência.

Exemplo: na string "12 13 15 18"

12 seria o primeiro (1), 13 o segundo (2), 15 o terceiro (3) e assim por diante.

  1. Cria um loop para copiar seus dados para o destino desejado.

    Sub Copia_Dados()
    
    Dim PLANILHA_ORIGEM As String
    Dim PLANILHA_DESTINO As String
    
    Dim COLUNA_CODIGO As String
    Dim COLUNA_DADOS As String
    
    Dim CELULA_DESTINO_CODIGO As String
    Dim CELULA_DESTINO_DADOS As String
    
    Dim rCODIGO As Range
    Dim rDADOS As Range
    
    Dim rCell As Range
    
    Dim NUM_INI As Double
    Dim NUM_FIM As Double
    
    Dim i As Integer
    
        Application.ScreenUpdating = False
    
        ' Define as planilhas
        PLANILHA_ORIGEM = "Plan1"
        PLANILHA_DESTINO = "Plan2"
    
        ' Define as colunas de código e dados (ORIGEM)
        COLUNA_CODIGO = "A"
        COLUNA_DADOS = "B"
    
        ' Define as células iniciias para código e dados (DESTINO)
        CELULA_DESTINO_CODIGO = "A1"
        CELULA_DESTINO_DADOS = "B1"
    
        ' Busca os dados das colunas com códigos e dados
        Set rCODIGO = Sheets(PLANILHA_ORIGEM).UsedRange.Columns(COLUNA_CODIGO)
        Set rDADOS = Sheets(PLANILHA_ORIGEM).UsedRange.Columns(COLUNA_DADOS)
    
        ' Loop na coluna de código
        For Each rCell In rCODIGO.Cells
    
            ' Buscas os números da célula
            NUM_INI = Extrair_Numero(rCell.Text, 1)
            NUM_FIM = Extrair_Numero(rCell.Text, 2)
    
            If NUM_INI < NUM_FIM Then
                For i = NUM_INI To NUM_FIM
                    ' Preenche os dados
                    Sheets(PLANILHA_DESTINO).Range(CELULA_DESTINO_CODIGO).Offset(i - 1, 0).Value = i
                    Sheets(PLANILHA_DESTINO).Range(CELULA_DESTINO_DADOS).Offset(i - 1, 0).Value =                 Sheets(PLANILHA_ORIGEM).Range(COLUNA_DADOS & rCell.Row).Value
                Next
            Else
                MsgBox "Os números '" & rCell.Text & "' informado em '" &         rCell.Address & "' não estão em sequência!", vbInformation, "Erro"
                Exit Sub
            End If
        Next
    
    End Sub
    

Atente-se para as configurações das variáveis para que os dados sejam transferidos do local de origem desejado para o local de destino.

Tentei deixar o mais abstrato possível.

No código atual, caso sua sequência não seja contínua, por exemplo 1 ao 10 e depois 30 ao 40, a planilha destino terá um "gap" do 11 ao 29, contudo se desta forma não atender dá pra adaptar algo para não pular as células, ou excluir as células em branco posteriormente.

Esperto ter ajudado!

1
  • Opa! Funcionou aqui! Excelente! Muito obrigado, Evert! :) Commented 15/09/2017 às 15:03
1

Resposta

Extrair Elemento

Primeiro a função de extrair elemento é declarada para extrair os elementos separados por espaço " ", em que cada elemento possui um index.

Exemplo.: 1 a 3 na célula A1, com a função EXTRACTELEMENT("A1",1," ") a resposta é 1 e para EXTRACTELEMENT("A1",2," ") a resposta é a

Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
 EXTRACTELEMENT = Split(Application.Trim(Txt), Separator)(n - 1)
End Function

Expandir (Código Principal)

Este código não está otimizado e se a planilha for muito grande (mais de 50 mil linhas), pode se tornar lenta.

Os elementos precisam ser em ordem ascendente, por exemplo:

+---+---------+
|   |    A    |
+---+---------+
| 1 | 1 a 3   |
| 2 | 6 a 9   |
| 3 | 20 a 23 |
+---+---------+

No entanto, se for fora de ordem, um erro ocorre. Por exemplo:

+---+---------+
|   |    A    |
+---+---------+
| 1 | 1 a 3   |
| 2 | 20 a 23 |
| 3 | 15 a 9  |
+---+---------+

Caso não seja em ordem ascendente, algumas condicionais devem ser adicionadas.

Dim ws As Worksheet
 Set ws = ThisWorkbook.Worksheets(1)

 Do While y <> 1
    lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    If i - 1 = lastrow Or lastrow = 1 Then y = 1
    For i = 1 To lastrow
       Let Rng = "A" & i
          If IsNumeric(ws.Range(Rng)) = False And ws.Range(Rng).Value <> "" Then
              ele1 = EXTRACTELEMENT(ws.Range(Rng), 1, " ")
              ele2 = EXTRACTELEMENT(ws.Range(Rng), 3, " ")
              On Error Resume Next
              j = ws.Range(Rng).Row
              x = CLng(ele2) - j
              Rows(j & ":" & j + x).Insert
              Z = ws.Cells(j + x + 1, 2)
              For k = ele1 To ele2
                  ws.Cells(k, 1) = k
                  ws.Cells(k, 2) = Z
              Next k
          Rows(j + x + 1).EntireRow.Delete
          End If
    Next i
 Loop

Opcional, descrição da função definida por usuário(UDF)

Adiciona descrição da função para ser mostrada ao utilizá-la na planilha Excel.

Sub DescribeFunction()
   Dim FuncName As String
   Dim FuncDesc As String
   Dim Category As String
   Dim ArgDesc(1 To 3) As String

   FuncName = "EXTRACTELEMENT"
   FuncDesc = "Returns the nth element of a string that uses a separator character/Retorna o enésimo elemento da string que usa um caractér separador."
   Category = 7 'Text category
   ArgDesc(1) = "String that contains the elements/String que contém o elemento"
   ArgDesc(2) = "Element number to return/ Número do elemento a retornar"
   ArgDesc(3) = "Single-character element separator/ Elemento único separador (spc por padrão)"

   Application.MacroOptions _
      Macro:=FuncName, _
      Description:=FuncDesc, _
      Category:=Category, _
      ArgumentDescriptions:=ArgDesc
End Sub

Opcional

Este código não realiza o que foi perguntado, por falta de atenção a tarefa contrária foi escrita.Porém pode ser utilizado após o código do Evert para agrupar e tornar planilhas muito grandes mais organizadas.

Este código primeiro reordena os dados da coluna B em ordem crescente, depois enumera na coluna A de 1 à última célula. Após isso agrupa os dados.

Conforme a imagem Exemplo

Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets(1)
rLastA = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
rLastB = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row

With ws
    On Error Resume Next
    .Outline.ShowLevels RowLevels:=8
    .Rows.Ungroup
    On Error GoTo 0
    Set r = ws.Range(ws.Cells(1, 2), ws.Cells(rLastB, 2))
End With

Range("B1").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

For i = 1 To 4
    ws.Cells(i, 1) = i
Next i
Range("A1:A4").AutoFill Destination:=Range("A1:A" & rLastB)

    With r
        'identify common groups in column B
        j = 1
        v = .Cells(j, 1).Value
        For i = 2 To .Rows.Count
            If v <> .Cells(i, 1) Then
                ' Colum B changed, create group
                v = .Cells(i, 1)
                If i > j + 1 Then
                    .Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
                End If
                j = i
                v = .Cells(j, 1).Value
            End If
        Next
        ' create last group
        If i > j + 1 Then
            .Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
        End If
        ' collapse all groups
        .Parent.Outline.ShowLevels RowLevels:=1
    End With

Application.ScreenUpdating = True

A seguir serão divididos cada parte do código para melhor entendê-lo

Desagrupamento

É realizado para reordenar corretamente a coluna B

With ws
    On Error Resume Next
    .Outline.ShowLevels RowLevels:=8
    .Rows.Ungroup
    On Error GoTo 0
    Set r = ws.Range(ws.Cells(1, 2), ws.Cells(rLastB, 2))
End With

Ordenação

Usa o Range.Sort para ordenar os valores da coluna B, este código foi retirado deste link

Range("B1").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Enumeração

Enumera até a última linha com o Autofill, a ferramenta de preenchimento automático do Excel, em que após selecionar o Range, dois cliques são dados no ponto preto do canto inferior da seleção

For i = 1 To 4
    ws.Cells(i, 1) = i
Next i
Range("A1:A4").AutoFill Destination:=Range("A1:A" & rLastB)

Agrupamento

Este código foi retirado do SO Global e realiza o agrupamento

    With r
        'identify common groups in column B
        j = 1
        v = .Cells(j, 1).Value
        For i = 2 To .Rows.Count
            If v <> .Cells(i, 1) Then
                ' Colum B changed, create group
                v = .Cells(i, 1)
                If i > j + 1 Then
                    .Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
                End If
                j = i
                v = .Cells(j, 1).Value
            End If
        Next
        ' create last group
        If i > j + 1 Then
            .Cells(j + 1, 1).Resize(i - j - 1, 1).Rows.Group
        End If
        ' collapse all groups
        .Parent.Outline.ShowLevels RowLevels:=1
    End With
1
  • Hahaha... Fica tranquilo! Estava tentando entender o que você queria dizer com a resposta. Obrigado pelo seu tempo de qualquer maneira. :) Commented 15/09/2017 às 13:06

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .