Midori

@Jeff_Sandes A macro deve ficar assim, Sub Macro() Call Coleta("Active", [B1:E25], [F2]) End Sub Sub Coleta(Valor As Variant, Area As Range, Destino As Range) Dim Coluna As Range Dim Linha As Long For Linha = 2 To Area.Rows.Count With WorksheetFunction If .CountIf(Area.Rows(Linha), Valor) > 0 Then Destino = Area.Cells(1, .Match(Valor, Area.Rows(Linha), 0)) End If Set Destino = Destino(2) End With Next Linha End Sub

Isso não acontece com o último código que postei. A macro também funciona com String e vai deixar o resultado igual esse print que postou. Pode anexar a planilha com a macro e os dados desse último print?

@Jeff_Sandes Aqui o resultado da macro foi as letras como no print que postou. Na chamada da função Coleta é só passar o range da sua planilha. Eu testei com A1:D6 e E2, então é só editar isso.

Não precisa testar cada coluna, é só aplicar uma função para identificar a coluna que tem o valor 1. Fiz isso com a Match. Sobre a quantidade de linhas, isso pode ser resolvido com um loop. Chegou a testar as últimas macros postas aqui no tópico? Elas fazem o que você descreveu.

@Jeff_Sandes Veja se assim resolve, Sub Macro() Call Coleta(1, [A1:D6], [E2]) End Sub Sub Coleta(Valor As Variant, Area As Range, Destino As Range) Dim Coluna As Range Dim Linha As Long For Linha = 2 To Area.Rows.Count With WorksheetFunction If .CountIf(Area.Rows(Linha), Valor) > 0 Then Destino = Area.Cells(1, .Match(Valor, Area.Rows(Linha), 0)) Set Destino = Destino(2) End If End With Next Linha End Sub

@Jeff_Sandes No post anterior o 1 aparece duas vezes na D e você colocou esse resultado duas vezes. Se não é para repetir deixe o critério assim, If Conta > 0 Then Destino = Coluna.Cells(0).Value Set Destino = Destino(2) End If A ordem do resultado importa? Pode acontecer do 1 aparecer mais de uma vez na mesma linha?

@Jeff_Sandes A coleta não está na ordem do exemplo, mas o primeiro parâmetro é o valor a ser localizado, o segundo é a tabela com o nome dos campos e o outro é para onde os dados devem ir. Sub Macro() Call Coleta(1, [A1:D6], [E2]) End Sub Sub Coleta(Valor As String, Area As Range, Destino As Range) Dim Coluna As Range Dim Conta As Long Set Area = Area.Offset(1).Resize(Area.Rows.Count - 1) For Each Coluna In Area.Columns Conta = WorksheetFunction.CountIf(Coluna, Valor) If Conta > 0 Then Destino.Resize(Conta) = Coluna.Cells(0).Value Set Destino = Destino(Conta + 1) End If Next Coluna End Sub

Pode mostrar um exemplo da tabela sem filtro e depois outro de como esses dados devem ficar após a coleta?

@isabela queiroz Se quer pegar a partir da coluna C, pode editar a linha do comando Copy, Busca.Offset(0, 1).Resize(1, 41).Copy

@isabela queiroz Suas planilhas estão com as tabelas assim nestas colunas? E com os filtros ativados?

Pode postar o print da tabela da aba Produtos?

Fiz na planilha que anexou aqui no tópico e não deu nenhum erro. Antes de executar você tem que criar a aba Produtos e lá deve colocar esta tabela, Nesse caso a macro que postei tem que ser modificada. Mas acho que devia tentar rodar só o meu código sem alteração na planilha que anexou aqui e com a tabela que comentei acima. Para só depois modificar algo se necessário.

@isabela queiroz Chegou a testar só o meu código na planilha que anexou aqui? O que quer dizer com "colar sem copia"? Não entendi o que quer fazer agora e a sua tabela de Produtos está diferente o que sugeri. Pode anexar o arquivo?

Pode anexar a planilha?

Já tentou editar as configurações de segurança?

@Sergio31 Com comentou no primeiro post, sua planilha tem um link RTD. Então acho melhor usar o evento Calculate em vez desse loop já que a cada atualização do link o Calculate será ativado. Private Sub Worksheet_Calculate() Application.EnableEvents = False Call ConectaDb Application.EnableEvents = True End Sub Sub ConectaDb() Dim Cnn As New ADODB.Connection Dim Rs As New ADODB.Recordset Dim PlanRTD As Worksheet Dim BancoDados As String Dim SQL As String Set PlanRTD = ThisWorkbook.Sheets("RTD9") BancoDados = ThisWorkbook.Path & "\DBace.accdb" Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & BancoDados & ";" & _ "Jet OLEDB:Database Password=MyDbPassword;" Cnn.Open SQL = "Select * from bd_rtd" Rs.Open SQL, Cnn, adOpenKeyset, adLockOptimistic Rs.AddNew Rs.Fields("num") = PlanRTD.Range("D9") Rs.Fields("hora") = PlanRTD.Range("D10") Rs.Fields("preco") = PlanRTD.Range("D11") Rs.Fields("qtd") = PlanRTD.Range("D12") Rs.Update Cnn.Close End Sub

@Sergio31 Aí já é questão de você explicar porque colocou esse loop e qual é o critério para enviar os valores para o banco e dados.

@Sergio31 Como tentou enviar os dados para o banco de dados? Executou a macro com F5? Não está salvando em outro banco de dados? Fiz um teste aqui e atualizou normalmente. Deixe os dois arquivos no mesmo diretório e a atribuição como postei, BancoDados = ThisWorkbook.Path & "\DBace.accdb"

@Swalls Parece que não entendeu o quer dizer "Próprio Excel". Não tem como configurar ou instalar p.ex alguma extensão no Excel e programar internamente em outra linguagem além do VBA.

@isabela queiroz Eu qual linha deu erro?

@isabela queiroz Esse é o código completo, para testar é só colar no Módulo e executar a sub Atualiza.

@isabela queiroz Crie uma nova aba (Produto) com a tabela, p.ex, Com essa relação a macro pode procurar e filtrar na planilha Sheet1, Sub Atualiza() Dim Produto As Range Set Produto = ThisWorkbook.Sheets("Produtos").[A2] While Produto <> "" Call CopiaProduto(Produto, Produto(1, 2)) Set Produto = Produto(2) Wend End Sub Sub CopiaProduto(ByVal Produto As String, ByVal Template As String) Dim Area As Range Dim Busca As Range Set Area = ThisWorkbook.Sheets("Sheet1").[A1].CurrentRegion Call Area.AutoFilter(Field:=3, Criteria1:=Produto) Set Area = Area.Resize(Area.Rows.Count, 1) If Area.Offset(1).SpecialCells(xlCellTypeVisible).Count > 1 Then Set Busca = ThisWorkbook.Sheets("TEMPLATE_PESO_MEDIDA").[B:B].Find( _ What:=Template, LookIn:=xlValues, LookAt:=xlWhole) If Not Busca Is Nothing Then Set Area = Area.Resize( _ Area.Rows.Count - 1, 1).Offset(1, 3).SpecialCells(xlCellTypeVisible) Busca.Resize(1, 42).Copy Area.PasteSpecial xlPasteValues Application.CutCopyMode = False End If End If End Sub

@Sergio31 Para testar coloque o banco de dados no mesmo diretório ou altere a atribuição, Sub ConectaDb() Dim Cnn As New ADODB.Connection Dim Rs As New ADODB.Recordset Dim PlanRTD As Worksheet Dim BancoDados As String Dim SQL As String Set PlanRTD = ThisWorkbook.Sheets("RTD9") BancoDados = ThisWorkbook.Path & "\DBace.accdb" Cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & BancoDados & ";" & _ "Jet OLEDB:Database Password=MyDbPassword;" Cnn.Open SQL = "Select * from bd_rtd" Rs.Open SQL, Cnn, adOpenKeyset, adLockOptimistic Do Rs.AddNew Rs.Fields("num") = PlanRTD.Range("D9") Rs.Fields("hora") = PlanRTD.Range("D10") Rs.Fields("preco") = PlanRTD.Range("D11") Rs.Fields("qtd") = PlanRTD.Range("D12") Rs.Update Loop Until PlanRTD.Range("D9") <> PlanRTD.Range("E9") Cnn.Close End Sub

@Barea Esses testes/elif não são necessários, com o dicionário só precisa de um. Aí estão as jogadas vitoriosas, então é só passar para dicionário e verificar com a outra, p.ex, if resultado[jogada1] == jogada2: print("Jogador 1 venceu") else: print("Jogador 2 venceu") E se quiser mostrar o tipo que venceu você pode usar uma lista e colocar a jogada como índice.

Para simplificar você pode usar um dicionário, p.ex, pedra = 0 tesoura = 1 papel = 2 jogada = { pedra: tesoura, tesoura: papel, papel: pedra } Assim a chave tem como valor as jogadas vitoriosas e a condicional só terá dois testes.