none
Criar botão para Preencher Células no Excel - VBA RRS feed

  • Pergunta

  • Prezados, bom dia.

    Preciso criar um botão que execute uma pesquisa em todas as planilha/pasta de trabalho, e preencha algumas células com valores/texto localizados nesta pesquisa.

    Ex.: Tenho uma planilha com uma sequência de abas nomeadas cronologicamente como CL0001, CL0002, CL0003, etc. Preciso que este código busque nessas planilhas o valor da célula C10 (é a mesma célula em todas as abas), e cole na planilha "RELATORIO", na célula E9. Importante: Ele deve "colar" o valor na próxima célula em branco abaixo, no caso E10, e assim sucessivamente (E11, E12, etc.).

    Ficando:

    Busque valor da célula C10 da planilha "CL0001" e cole na célula E9 da planilha "RELATORIO";

    Busque valor da célula C10 da planilha "CL0002" e cole na célula E10 da planilha "RELATORIO";

    Busque valor da célula C10 da planilha "CL0003" e cole na célula E11 da planilha "RELATORIO";

    ...

    Desculpe ser um tanto repetitivo nas instruções, quis apenas ser claro para melhor entendimento.

    Desde já agradeço a ajuda!

    Abs e um ótimo fds!

    Rafael


    Rafael Alan

    domingo, 10 de abril de 2016 12:16

Respostas

  • Sub Main()
        Dim wsRelatório As Worksheet
        Dim iWS As Worksheet
        Dim PasteRow As Long
        Dim i As Long
        
        Set wsRelatório = ThisWorkbook.Worksheets("RELATORIO")
        Do
            i = i + 1
            
            Set iWS = Nothing
            On Error Resume Next
            Set iWS = ThisWorkbook.Worksheets("CL" & Format(i, "0000"))
            On Error GoTo 0
            If iWS Is Nothing Then Exit Do
            
            PasteRow = wsRelatório.Cells(wsRelatório.Rows.Count, "E").End(xlUp).Row + 1
            PasteRow = WorksheetFunction.Max(PasteRow, 10)
            wsRelatório.Cells(PasteRow, "E") = iWS.Range("C10")
        Loop While Err.Number = 0
            
    End Sub
    


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

    • Marcado como Resposta Rafael Alan terça-feira, 12 de abril de 2016 13:45
    terça-feira, 12 de abril de 2016 12:42
    Moderador

Todas as Respostas

  • Sub Main()
        Dim wsRelatório As Worksheet
        Dim iWS As Worksheet
        Dim PasteRow As Long
        Dim i As Long
        
        Set wsRelatório = ThisWorkbook.Worksheets("RELATORIO")
        Do
            i = i + 1
            
            Set iWS = Nothing
            On Error Resume Next
            Set iWS = ThisWorkbook.Worksheets("CL" & Format(i, "0000"))
            On Error GoTo 0
            If iWS Is Nothing Then Exit Do
            
            PasteRow = wsRelatório.Cells(wsRelatório.Rows.Count, "E").End(xlUp).Row + 1
            PasteRow = WorksheetFunction.Max(PasteRow, 10)
            wsRelatório.Cells(PasteRow, "E") = iWS.Range("C10")
        Loop While Err.Number = 0
            
    End Sub
    


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

    • Marcado como Resposta Rafael Alan terça-feira, 12 de abril de 2016 13:45
    terça-feira, 12 de abril de 2016 12:42
    Moderador
  • Obrigado pela ajuda!!

    Rafael Alan

    terça-feira, 12 de abril de 2016 13:45