Excel Macro para auto-preenchimento "copiar dados de coluna p/ uma tabela na vertical"

[Batista.fcm]

Ola Prezados!

 

Estou tentando buscar uma solução seja por formula ou VBA para executar auto preenchimento. A ideia é que pegue os dados que sao inseridos manualmente em uma coluna e os copie de maneira ordenada em uma tabela vertical. Será que isso é possível dentro do Excel ou será que existe uma outra função para esse fim?

 

Para facilitar o entendimento estou anexando uma imagem explicando o passo a passo da mecânica e também disponibilizando o arquivo em Excel caso alguém possa me ajudar com as suas habilidades e conhecimentos.

 

Desde já agradeço pelo help!

TESTE_VBA_AUTO.PREENCHIMENTO.xlsx

[Midori]

Com macro acho que será mais fácil. Você pode fazer dois loops aninhados e controlar as variáveis das linhas e colunas. Para o quadro que recebe os valores, a variável da coluna será decrementado e da linha também quando chegar na coluna BC, p.ex:

 

Quadro(L, C).Value = Valor(Linha).Value
C = C - 1
If C Mod [BC:BC].Column = 0 Then
    L = L - 1
    C = Quadro.Columns.Count
End If

 

[Batista.fcm]

ola saudações @Midori !

 

Muito obrigado por retornar uma resposta a minha duvida, agradeço sinceramente pela sua disposição e tempo dedicados para me responder.

 

Infelizmente sou usuário básico de Excel, para fazer um Procx eu já tenho dificuldades, imagina então tentar ler e entender uma lógica de programação como a sua sugestão. Nesse caso eu não consigo avançar na minha solução para o problema apresentado... Caso desejar e se for possível, consegue testar essa macro no arquivo em anexo - de antemão sou agradecido pela a ajuda.

[Midori]

O código completo,

 

Sub PreencheQuadro()
    Dim Area    As Range
    Dim Quadro  As Range
    Dim Lin     As Long
    Dim L       As Long
    Dim C       As Integer
    Dim Col     As Integer
    
    Set Area = [D11:AL17]
    Set Quadro = [BC10:BK17]
    L = Quadro.Rows.Count
    C = Quadro.Columns.Count
    
    For Col = 1 To Area.Columns.Count
        For Lin = 1 To Area.Rows.Count
            If Area(Lin, Col).Value <> "" Then
                Quadro(L, C).Value = Area(Lin, Col).Value
                C = C - 1
                If C Mod Quadro.Columns(1).Column = 0 Then
                    L = L - 1
                    C = Quadro.Columns.Count
                End If
            End If
        Next Lin
    Next Col
End Sub

 

[Batista.fcm]

@Midori , bom dia!

 

Excelente! 100% de acerto, ficou perfeito e era exatamente minha necessidade... Muito, mas muito obrigado mesmo por sua ajuda!

 

Parabéns também pela existência desse grupo, por muitas vezes vejo soluções e ideias de outros problemas que eu também posso aplicar em minhas necessidades e é fantástico observar que ainda hoje em dia existam pessoas contribuem ajudem o próximo, mesmo que para isso elas tenham de abrir mao de um tempo seu para ajudar a um outro.

 

Muito obrigado!

[Midori]

Com fórmula no Excel 365 consegui chegar no mesmo resultado. A função chave para isso é a TOCOL (ou TOROW) que é capaz de pegar um arranjo/matriz NxM e transformar em Nx1 (ou vetor). E para facilitar ainda mais tem o recurso para remover dados em branco e configurar a organização deles.

 

A função já deixa os dados na ordem correta,

 

 

Aí é só indexar para formar a outra matriz,

[Batista.fcm]

Ola @Midori tudo bem com você, espero que sim!!!!

 

Ja utilizei bastante a solução que você conseguiu para mim através do codgo VBA.

Infelizmente não possuo a versão 365 da microsoft.

 

Gostaria muito de poder contar com sua ajuda novamente, preciso de algo que imagino ser simples para vocês mas que eu não sei fazer....

 

Gostaria apenas de mudar a posição das informações conforme o anexo do arquivo.

 

a imagem também ajuda a mostrar a alteração que gostaria que pudesse fazer no codgo VBA:

 

 

TESTE_VBA_AUTO.PREENCHIMENTO(1).xlsx

[OreiaG]

Olá, @Batista.fcm

 

Segue uma solução, caso você queira experimentar.

Considerei a origem dos dados em D11:O16 e o destino a partir de AF11:AF16. Retorne se precisar ajustes nesses intervalos.

 

Sub ReplicaDados()
 Dim cO As Long, rO As Long, i As Long, v As Long
 Dim cD As Long, rD As Long, k As Long, Narr(1 To 100)
  [AF11:AM16] = ""
  k = Application.CountA(Range("D11:O16"))
  For cO = 4 To 15
   For rO = 11 To 11 + Application.CountA(Cells(11, cO).Resize(6)) - 1
    Narr(i + 1) = Cells(rO, cO).Value: i = i + 1
   Next rO
  Next cO
  For v = LBound(Narr) To UBound(Narr)
   Cells(11 + rD, 32 + cD) = Narr(v): rD = rD + 1
   If v = k Then
    Exit Sub
   ElseIf v Mod 6 = 0 Then
    rD = 0: cD = cD + 1
   End If
  Next v
End Sub

 

[Batista.fcm]

@OreiaG!

 

Muito obrigado por entrar em contato!

 

Sim você consegui-o entender perfeitamente a minha ideia.

 

Tentei fazer uma modificação no codgo, para que ele pudesse atender um numero maior de celulas, porém ele da um erro que não consigo encontrar como corrigir.

 

Alterei o codgo dessa maneira:

 

Sub ReplicaDados()
 Dim cO As Long, rO As Long, i As Long, v As Long
 Dim cD As Long, rD As Long, k As Long, Narr(1 To 100)
  [BN11:DK16] = ""
  k = Application.CountA(Range("D11:BJ16"))
  For cO = 4 To 61
   For rO = 11 To 11 + Application.CountA(Cells(11, cO).Resize(6)) - 1
    Narr(i + 1) = Cells(rO, cO).Value: i = i + 1
   Next rO
  Next cO
  For v = LBound(Narr) To UBound(Narr)
   Cells(11 + rD, 66 + cD) = Narr(v): rD = rD + 1
   If v = k Then
    Exit Sub
   ElseIf v Mod 6 = 0 Then
    rD = 0: cD = cD + 1
   End If

 

 

e nessa foto é o erro que esta dando:

 

Por gentileza, consegue ajudar

 

[OreiaG]

5 horas atrás, Batista.fcm disse:

 

Tentei fazer uma modificação no codgo, para que ele pudesse atender um numero maior de celulas, porém ele da um erro que não consigo encontrar como corrigir.

 

Por gentileza, consegue ajudar

 

 

Sim, podemos tentar ajudar, mas precisamos que você nos Informe com exatidão o significado de "atender um numero maior de celulas". (células)

[Batista.fcm]

14 horas atrás, OreiaG disse:

Sim, podemos tentar ajudar, mas precisamos que você nos Informe com exatidão o significado de "atender um numero maior de celulas". (células)

Opa boa noite amigo!

 

obrigado por manter contato, Verdade né, preciso especificar melhor isso.  Vamos la:

 

Aproveitando sua introdução,

" Segue uma solução, caso você queira experimentar.

Considerei a origem dos dados em D11:O16 e o destino a partir de AF11:AF16. Retorne se precisar ajustes nesses intervalos."

 

Formatei o layout da Planilha e então ficou assim os dados:

Origem dos dados em D3:AOP16

Destino a partir de D20:AOP25

 

aproveito também para deixar a imagem caso sirva de ajuda. Precisando de mais informações por favor sinta-se a vontade para perguntar.

 

 

 

[OreiaG]

Olá, @Batista.fcm

 

"aproveito também para deixar a imagem caso sirva de ajuda."

 

Não é possível testar macros em imagens, então precisamos do arquivo Excel com os dados relevantes e o resultado desejado na planilha.

 

 

[Batista.fcm]

Ola bom dia @OreiaG !

 

tudo certo,

 

segue-se em anexo ja formatado no padrão final:

AUTO.PREENCHIMENTO.CLUBE.DO.HARDWARE.xlsm.zip

[OreiaG]

Segue um código meio que na adivinhação pois o layout é totalmente diferente do modelo simplificado anexado ao post #7 e você não colocou o resultado desejado e não passou qualquer explicação.

 

Sub ReplicaDados_V2()
 Dim cO As Long, i As Long, v As Long, LC As Long, dtO As Range
 Dim cD As Long, rD As Long, k As Long, Narr(1 To 16000)
  [D20:AOP25] = ""
  Application.ScreenUpdating = False
  k = Application.CountA(Range("D3:AOP16"))
  LC = Rows("3:16").Find(what:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
  For cO = 4 To LC
   If Application.CountA(Cells(3, cO).Resize(14)) > 0 Then
    For Each dtO In Cells(3, cO).Resize(14).SpecialCells(2)
     Narr(i + 1) = dtO.Value: i = i + 1
    Next dtO
   End If
  Next cO
  For v = LBound(Narr) To UBound(Narr)
   Cells(20 + rD, 4 + cD) = Narr(v): rD = rD + 1
   If v = k Then
    Exit Sub
   ElseIf v Mod 6 = 0 Then
    rD = 0: cD = cD + 1
   End If
  Next v
End Sub

 

obs.

1. antes de testar remova o texto FIM da célula AOP16
2. para o correto funcionamento do código acima as células à direita de AOP3:AOP16 deverão permanecer vazias

3. "Destino a partir de D20:AOP25" >>> a partir de D20:D25

[Batista.fcm]

@OreiaG !

 

Perfeito amigo!!!

 

Ficou exatamente como o esperado. Mais uma vez tenho que agradecer muito por existir esse clube do Hardware e também por existirem pessoas como você e os demais amigos que dedicam parte do seu tempo para poder ajudar aos outros!!!

 

Fico feliz e agradecido porque realmente eu não tenho capacidade nenhuma de criar um codgo assim, sou apenas usuário da ferramenta do Excel.

 

Mais uma vez obrigado @OreiaG e que Deus continue te abençoando com sabedoria, forte abraço.

[OreiaG]

@Batista.fcm  Que bom que funcionou.

 

Ficamos contentes por você ter encontrado uma solução.

 

Deus lhe abençoe também, saúde, paz e sucesso.