Macro copiar volares em colunas procura por dia

Question

Bom dia pessoal!

 

A situação é a seguinte;

 

Tenho uma planinha que dia a dia na sheet1 ela me dá na coluna "B" uma quantidade de valores diferentes (B4:B20), estes valores são puxados através de formula, ou seja, eu vejo os valores, porém na coluna/linha tem uma formula. Este valores/formulas eu copio e colo como valores na sheet2 na coluna referente ao dia.

 

Sheet1 – Data (=today) e Dia (=day(today())

O valor é obtido com formula

25/1/2011
Dia	25
Valor	2
Valor	3

 

 

Sheet2 – Dias fixos na planilha -

 

Dia	1	2	3	4	25
Valor					2
Valor					3

 

 

Quero criar uma macro que verifique o dia da sheet1 com a posição do dia da sheet2 e quando encontrada esta posição, o valor da coluna B da sheet1 seja colado na sheet2

Answer 1

Construa uma Pasta de Trabalho assim:

 

Planilha Plan1:

A1 = Dia

A2 = Valor

A3 = Valor

A4 = Valor

B1 = 12/01/2011

B2 = 1

B3 = 2

B4 = 3

 

Planilha Plan2:

A1 = 01/01/2011

B1 = 02/01/2011

C1 = 03/01/2011

... até ...

AE1 = 31/01/2011

 

Utilize o código abaixo:

 

Sub ColarValores()
  
  Dim wsO As Worksheet, wsD As Worksheet
  Dim i As Long, rLastO As Long, rLastD As Long, lCol As Long
  Dim dDia As Date
  Dim rngBanco As Range, rng As Range
  
  Set wsO = Sheets("Plan1")
  Set wsD = Sheets("Plan2")
  
  With wsO
    rLastO = .Cells(.Rows.Count, "A").End(xlUp).Row
    dDia = .Range("B1")
    Set rngBanco = wsD.Rows(1)
    Set rng = rngBanco.Find(dDia)
    lCol = rng.Column
    rLastD = wsD.Cells(wsD.Rows.Count, lCol).End(xlUp).Row
    .Range("B2").Resize(rLastO).Copy Destination:=wsD.Cells(1, lCol).Offset(rLastD)
  End With
  
End Sub

 

Se quiser um exemplo pronto, baixe aqui: http://www.megaupload.com/?d=RJAAGC4K

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 2

Fala velhinho, pelo que testei não funcionou.

 

Segue ai uma idéia do que estou tentando fazer;

 

Sub testemacro()

   

    Range("A2:A7").Select                                                                'Selecionas linhas da coluna

    Selection.Copy                                                                              'Copia as células selecionadas

    Sheets("Sheet2").Select                                                            'Muda para a sheet2

    Range("A2").Select                                                                     'Clica na selula A2

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False                                                    'Faz a copia especial

    Sheets("Sheet1").Select

    Application.CutCopyMode = False

End Sub

 

Mas, além disto, eu preciso de uma forma de primeiro testar a data da planilha1 com a planilha2, quando a data for encontrada realizar esta operação.

 

A operação deverá ser acionada através de um botão na planilha1.

 

Será que tem como ser feito isso?

 

Grato,

 

Answer 3

Você baixou o exemplo no link que eu postei? Está funcionando. Através do método Find o programa faz esse teste que você citou.

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 4

A macro do Benzadeus está correta. É necessário ajustar ao seu caso.

Tente:

 

Option Explicit

Sub ColarValores()
   
    Dim wsO As Worksheet, wsD As Worksheet
    Dim i As Long, rLastO As Long, rLastD As Long, lCol As Long
    Dim dDia As Integer
    Dim rngBanco As Range, rng As Range
   
    Set wsO = Sheets("Plan1")
    Set wsD = Sheets("Plan2")
   
    With wsO
        rLastO = .Cells(.Rows.Count, "A").End(xlUp).Row
        dDia = .Range("B1")
        Set rngBanco = wsD.Rows(1 )
        Set rng = rngBanco.Find(dDia)
        lCol = rng.Column
        rLastD = wsD.Cells(wsD.Rows.Count, lCol).End(xlUp).Row
        .Range("B2").Resize(rLastO).Copy Destination:=wsD.Cells(1, lCol).Offset(rLastD)
    End With
   
End Sub

Os números de 1 a 31 em Plan2 devem estar na linha 1. Se não estiverem, troque o 1 do código (em negrito) pela linha em que estão.

 

Abs,

 

 

 

Answer 5

Valeu galera!

O código de Benzadeus estava blz, eu é que não tinha conseguido fazer as mudanças necessárias. Acho que trabalhar a noite causa isso, rsrsrsr.

 

grato,

 

Answer 6

Bem pessoal, estive fazendo outros testes e minha necessidade mudou.

 

Dentro do que eu pedi anteriormente, a rotina está funcionando muito bem, porém a minha necessidade é outra e como sou novo em VBA pessoa ajuda de vocês mais uma vez.

 

Segue link com a planilha semelhante a que uso.

 

http://www.megaupload.com/?d=SYQAS7U1

 

O dia é obtido através de formula   ( =day(today()) formatada como número)

Copio  D15:46  e colo especial na planilha ACUMULADOS referente a cada dia e o mesmo faço com a coluna E

Na ACUMULADOS a formatação dos número é como geral

 

Não estou conseguindo percorrer os dias.

 

Tem como me ajudarem novamente?

Answer 7

O que quer dizer que não está conseguindo percorrer os dias?

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 8

Como a configuração de minha tabela é diferente da que foi proposta anteriormente, exemplo:

A data principal da tabela BCO_DADOS em minha planilha é uma formula ( =day(today()) ) e está em uma coluna/linha diferente da tabela proposta anteriormente por vc.

A data na planilha ACUMULADOS é apenas uma numeração de 01 a 31 e não necessariamente uma "data" (não há a formatação como data e sim geral) e a proposta por vc, tem formatação de data.

Creio que este seja o problema em minha planilha, não sei se necessariamente tem que ter a formatação da data nas duas planilha ou se tem como funcionar com formatação diferente?

 

Answer 9

Bom dia pessoal!

 

 

Consegui fazer funcionar do jeito que eu queria. Criei uma estrutura em IF..ELSEIF..ENDIF e está funcionado blz.

O código ficou grande, mas como está funcionando do jeito que eu queria, então tudo bem.

 

Grato pela ajuda de todos.

Fuuuiii.