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

  • Pergunta

  • 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.

    quarta-feira, 20 de julho de 2016 16:45

Respostas

  • 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
    
    

    • Marcado como Resposta Vitor Alberto quinta-feira, 21 de julho de 2016 17:59
    quinta-feira, 21 de julho de 2016 17:52

Todas as Respostas

  • 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

    quinta-feira, 21 de julho de 2016 12:14
    Moderador
  • 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??


    quinta-feira, 21 de julho de 2016 15:55
  • 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

    • Marcado como Resposta Vitor Alberto quinta-feira, 21 de julho de 2016 17:58
    • Não Marcado como Resposta Vitor Alberto quinta-feira, 21 de julho de 2016 17:58
    quinta-feira, 21 de julho de 2016 17:28
    Moderador
  • 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
    
    

    • Marcado como Resposta Vitor Alberto quinta-feira, 21 de julho de 2016 17:59
    quinta-feira, 21 de julho de 2016 17:52