Usuário com melhor resposta
Criar botão para Preencher Células no Excel - VBA

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