Localizar datas a partir de uma seleção e copiar para outra célula

Question

Olá,

     Gostaria de procurar eventos com a data do dia de 'hoje()' e copiar a linha inteira desses eventos para outras células.

     Primeiramente eu seleciono todas as células em que será feita a procura:

           

Sheets("AGENDADAS").Select
Rows("G5:L5").Select
Range(Selection, Selection.End(xlDown)).Select

     Depois eu gostaria de, por exemplo, se houver uma data igual ao dia de hoje em alguma das células selecionadas, copia a linha inteira onde a data foi encontrada para outra planilha. Como posso continuar o código? Seria algo como: SE (valor da célula) = hoje() ENTÃO copia a linha. Alguém pode me ajudar? Sou muito iniciante no VBA.

Answer 1

Vitor, não selecione células assim. Evite usar os métodos Select e os objetos ActiveSheet. Veja aqui.

---

Adapte este código:

Private Sub Main()
    Dim iRow As Long
    Dim NewRow As Long
    Dim LastRow As Long
    Dim ws As Worksheet
    
    'Considerando que a outra planilha tem uma linha de cabeçalho
    NewRow = 1
    
    Set ws = ThisWorkbook.Worksheets("AGENDADAS")
    With ws
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        'Considernado uma linha de cabeçalho
        For iRow = 2 To LastRow
            'Considrando que coluna L possui as datas
            If .Cells(iRow, "L").Value <> Date Then GoTo Continue
            
            NewRow = NewRow + 1
            ThisWorkbook.Worksheets("OutraPlanilha").Cells(NewRow, "A").Resize(, 6).Value2 = ws.Cells(iRow, "G").Resize(, 6).Value2
Continue:
        Next iRow
    End With
End Sub

---

http://www.ambienteoffice.com.br - http://www.clarian.com.br

Answer 2

Olá, fiz as seguintes adaptações. Mas, por ser muito iniciante, não compreendi muito bem como o código copiaria os valores das colunas B:F da linha em que foi encontrada uma data igual a de "hoje". Testei meu código e parece que ele não realiza nada. O que pode estar errado? 



Segue:



    Sub Gather()

    Dim iRow As Long 'contador (de linhas)
    Dim iCol As Long 'contador (de colunas)
    Dim CurrentRow As Long 'variável da linha varrida no momento
    Dim EndRow As Long 'variável de última linha não vazia
    Dim EndCol As Long 'variável de última coluna não vazia
    Dim ws As Worksheet

    HeadHOJE = 7 'cabeçalho da planilha HOJE tem 7 linhas
    StartColHOJE = 2 'coluna da planilha HOJE que será inserido os valores
    StartColAG = 2 'coluna inicial da planilha AGENDADAS que se obtém os valores

    'a procura será feita em todas as linhas não vazias das colunas de G à L
    CurrentCol = 7 'coluna ("G") em que começa-se a procurar
    EndCol = 12 'coluna ("L") em que termina-se a busca

    CurrentRow = 4 'Considerando que a outra planilha tem uma linha de cabeçalho

    Set ws = ThisWorkbook.Worksheets("AGENDADAS")
    With ws
        EndRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'número da linha da célula mais no fundo e não vazia da coluna A.

        For iCol = (CurrentCol) To EndCol
            For iRow = (CurrentRow + 1) To EndRow 'varredura do início ao fim das células da coluna CurrentCol
                If .Cells(iRow, CurrentCol).Value = Date Then 'se o valor da célula for igual da data de "hoje", faça:
                    ThisWorkbook.Worksheets("HOJE").Cells(HeadHOJE + 1, StartColHOJE).Resize(, 6).Value2 = ws.Cells(CurrentRow, StartColAG).Resize(, 6).Value2
                    HeadHOJE = HeadHOJE + 1
                End If
            Next iRow

        Next iCol


    End With
    End Sub





Também tenho algumas dúvidas extras, por exemplo:

 - O que esse Resize faz... li no site mas não compreendi sua função nessa linha.

 - Qual o motivo de colocar "Private Sub", o que é isso? e Main??

Answer 3

Ao inserir um código no fórum, utilize blocos de código. Para utilizar essa ferramenta, clique no botão cuja legenda é “Inserir bloco de código” na barra do editor de mensagens do fórum. Uma janela aparecerá onde você deverá colar seu código cru na caixa de texto à esquerda. Então, selecione a opção Vb.Net na caixa de combinação que você verá em cima à esquerda e depois clique no botão Inserir.

---

Seu código não está compilando. É essencial que seu código esteja indentado e compilando.

---

Tente novamente com o código abaixo e volte a postar:

Sub Gather()
    'a procura será feita em todas as linhas não vazias das colunas de G à L
    Const FIRST_COLUMN = "G" 'coluna ("G") em que começa-se a procurar
    Const LAST_COLUMN = "L" 'coluna ("L") em que termina-se a busca
    
    Const AGENDADAS_HEADER_ROW = 4 'linha do cabeçalho em AGENDADAS
    Const HOJE_HEADER_ROW = 7 'linha do cabeçalho em HOJE
    Const PASTE_COLUMN = "B" 'coluna onde são lidos os dados de uma planilha e colada em outra
    
    Dim iRow As Long 'contador (de linhas)
    Dim iCol As Long 'contador (de colunas)
    Dim LastAgendadasRow As Long 'variável de última linha não vazia
    Dim wsAgendadas As Worksheet
    Dim wsHoje As Worksheet
    Dim HojeRow As Long
    Dim PasteWidth As Long 'largura (em células) de dados para copiar e colar
    
    With ThisWorkbook
        Set wsAgendadas = .Worksheets("AGENDADAS")
        Set wsHoje = .Worksheets("HOJE")
    End With

    HojeRow = HOJE_HEADER_ROW + 1 'dados serão gravados uma linha após o cabeçalho
    PasteWidth = GetColumnNumberByLetter(LAST_COLUMN) - GetColumnNumberByLetter(FIRST_COLUMN) + 1

    For iRow = AGENDADAS_HEADER_ROW + 1 To GetLastRow(wsAgendadas.Columns("A")) 'varredura do início ao fim das células da coluna CurrentCol
        For iCol = GetColumnNumberByLetter(FIRST_COLUMN) To GetColumnNumberByLetter(LAST_COLUMN)
            If wsAgendadas.Cells(iRow, iCol).Value <> Date Then GoTo Continue 'se o valor da célula for igual da data de "hoje", faça:
            
            ThisWorkbook.Worksheets("HOJE").Cells(iRow, PASTE_COLUMN).Resize(, 6).Value2 = wsAgendadas.Cells(HojeRow, PASTE_COLUMN).Resize(, 6).Value2
            HojeRow = HojeRow + 1
Continue:
        Next iCol
    Next iRow
End Sub

Private Function GetLastRow(pColumn As Range) As Long
    Dim ParentWorksheet As Worksheet
    Dim Result As Long
    
    Set ParentWorksheet = pColumn.Parent
    With ParentWorksheet
        Result = .Cells(.Rows.Count, pColumn.Column).End(xlUp).Row
    End With
    
    GetLastRow = Result
End Function

Private Function GetColumnNumberByLetter(pColumnAddress As String) As Long
    Dim Result As Long
    Dim i As Long
    Dim FixedAddress As String
    Dim iCharacter As String
    Dim iMultiplier As Long
    
    FixedAddress = UCase(pColumnAddress)
    For i = 1 To Len(FixedAddress)
        iCharacter = Mid(FixedAddress, i, 1)
        iMultiplier = 26 ^ (Len(FixedAddress) - i)
        Result = Result + (Asc(iCharacter) - 64) * iMultiplier
    Next i

    GetColumnNumberByLetter = Result
End Function

---

http://www.ambienteoffice.com.br - http://www.clarian.com.br

Answer 4

FUNCIONOU PERFEITAMENTE! Fiz algumas poucas alterações (de lógica), mas no fim funcionou. Fiquei muito satisfeito.

Segue o código alterado:

Sub Atualização()
    'a procura será feita em todas as linhas não vazias das colunas de G à L
    Const FIRST_COLUMN = "G" 'coluna ("G") em que começa-se a procurar
    Const LAST_COLUMN = "L" 'coluna ("L") em que termina-se a busca
    
    Const AGENDADAS_HEADER_ROW = 4 'linha do cabeçalho em AGENDADAS
    Const HOJE_HEADER_ROW = 7 'linha do cabeçalho em HOJE
    Const PASTE_COLUMN = "B" 'coluna onde são lidos os dados de uma planilha e colada em outra
    
    Dim iRow As Long 'contador (de linhas)
    Dim iCol As Long 'contador (de colunas)
    Dim LastAgendadasRow As Long 'variável de última linha não vazia
    Dim wsAgendadas As Worksheet
    Dim wsHoje As Worksheet
    Dim HojeRow As Long
    Dim PasteWidth As Long 'largura (em células) de dados para copiar e colar
    
    With ThisWorkbook
        Set wsAgendadas = .Worksheets("AGENDADAS")
        Set wsHoje = .Worksheets("HOJE")
    End With

    HojeRow = HOJE_HEADER_ROW + 1 'dados serão gravados uma linha após o cabeçalho
    PasteWidth = GetColumnNumberByLetter(LAST_COLUMN) - GetColumnNumberByLetter(FIRST_COLUMN) + 1

    For iRow = AGENDADAS_HEADER_ROW + 1 To GetLastRow(wsAgendadas.Columns("A")) 'varredura do início ao fim das células da coluna CurrentCol
        For iCol = GetColumnNumberByLetter(FIRST_COLUMN) To GetColumnNumberByLetter(LAST_COLUMN)
            If wsAgendadas.Cells(iRow, iCol).Value <> Date Then GoTo Continue 'se o valor da célula for diferente da data de "hoje", continua o loop
            
            ThisWorkbook.Worksheets("HOJE").Cells(HojeRow, PASTE_COLUMN).Resize(, 6).Value2 = wsAgendadas.Cells(iRow, PASTE_COLUMN).Resize(, 6).Value2
            HojeRow = HojeRow + 1
Continue:
        Next iCol
    Next iRow
End Sub

Private Function GetLastRow(pColumn As Range) As Long
    Dim ParentWorksheet As Worksheet
    Dim Result As Long
    
    Set ParentWorksheet = pColumn.Parent
    With ParentWorksheet
        Result = .Cells(.Rows.Count, pColumn.Column).End(xlUp).Row
    End With
    
    GetLastRow = Result
End Function

Private Function GetColumnNumberByLetter(pColumnAddress As String) As Long
    Dim Result As Long
    Dim i As Long
    Dim FixedAddress As String
    Dim iCharacter As String
    Dim iMultiplier As Long
    
    FixedAddress = UCase(pColumnAddress)
    For i = 1 To Len(FixedAddress)
        iCharacter = Mid(FixedAddress, i, 1)
        iMultiplier = 26 ^ (Len(FixedAddress) - i)
        Result = Result + (Asc(iCharacter) - 64) * iMultiplier
    Next i

    GetColumnNumberByLetter = Result
End Function