Macro Excel

Olá Equipe !

Analisando mais a fundo a necessidade do nosso parceiro e utilizando como base o código do Elvis, tomei a liberdade de gerar um novo código que permite um pouco mais de dinamismo na execução das funções que compartilho abaixo. Caso alguém queira, tenho um arquivo de exemplo do funcionamento das funções que pode ser solicitado via e-mail.

Conforme já explicado pelo Elvis, tem-se primeiro que criar um módulo para copiar e colar o códigos. Além disto deve-se criar dois botões na planilha onde serão cadastradas as pessoas para que sejam atribuídos a eles as macros criar e deletar planilhas.


----O código abaixo permite a criação das planilhas com base nas pessoas cadastradas na coluna A(configurável)
**********************************************************************************
Sub criaPlanilhas()

'declarando as variaveis
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim novaformula As String 'armazena formula que vai ser inserida na celula
Dim concatenador As String ' constroi a formula a ser adicionada na celula
Dim nomePlanilhaLista As String ' armazena o nome da planilha onde esta sua lista de pessoas
Dim nomePlanilhaNova As String ' armazena o nome da planilha que você irá criar

'Verificar o erro da planilha ser ter espaços vazios ateh o nome das pessoas

'atribui automaticamente a y um valor igual ao numero de linhas preenchidas na coluna A
'Ex: se na coluna A Temos algo escrito na celula y sera igual a 6
y = Range("A65536").End(xlUp).Row

Application.ScreenUpdating = False

'y = ActiveSheet.UsedRange.Cells.Count

For x = 12 To y 'declarando onde começa e onde termina a variável q usaremos para as linhas

nomePlanilhaLista = ActiveSheet.Name
nomePlanilhaNova = ActiveSheet.Cells(x, 1).Value 'definindo o nome da nova planilha, "a" é a variável da linha e 1 é a coluna, vc pode mudar isto...

'Compara as planilhas que existem com as pessoas cadastradas
'Se a planilha já existe ele sai da rotina, senao, ele cria a planilha
For z = 1 To Worksheets.Count

If Sheets(z).Name = nomePlanilhaNova Then GoTo Planilha_ja_existe

Next

Sheets.Add , After:=Worksheets(Worksheets.Count) 'adicionando uma nova planilha como última no arquivo
ActiveSheet.Name = nomePlanilhaNova 'renomeando a nova planilha com o nome da pessoa
ActiveSheet.Range("A1").Select 'seleciona a celular onde ele vai colocar um link para voltar para a base de cadastro
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=nomePlanilhaLista & "!A1", TextToDisplay:="Voltar" 'o código abaixo coloca um hyperlink na Celula A1 para a planilha do cadastro, se não quiser usar isto, é só excluir a linha
Sheets(nomePlanilhaLista).Select 'retorna à planilha de lista
ActiveSheet.Cells(x, 1).Select 'Seleciona a celula para inserir o link
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=nomePlanilhaNova & "!A1", TextToDisplay:=nomePlanilhaNova 'o código abaixo coloca um hyperlink para a nova planilha, se não quiser usar isto, é só excluir a linha
concatenador = concatenador & nomePlanilhaNova & "!" & Sheets(nomePlanilhaNova).Range("A3").Address & ","


Planilha_ja_existe:
Next

'constroi a formula que sera imputada na celula
novaformula = "=sum(" & Left(concatenador, Len(concatenador) - 1) & ")"

'inputa a formula na celula desejada, no caso é a A1 da planilha Lista, pois ela é a ActiveSheet(planilha ativa) no momento
ActiveSheet.Range("A1").Value = novaformula

MsgBox "Planilhas Criadas Com Sucesso !", vbInformation

Application.ScreenUpdating = True

End Sub
**********************************************************************************


----O código abaixo verifica todas as pessoas cadastradas na coluna A e compara as mesmas com as planilhas criadas, se alguma planilha não tiver seu nome cadastrado na coluna A, ela é excluída automaticamente.

Este código considera que existe apenas uma planilha que seria a Base de cadastro e quaisquer outras são planilhas geradas a partir desta.

**********************************************************************************
Sub deletaPlanilhas()

'declarando as variaveis
Dim x As Integer
Dim y As Integer
Dim z As Integer
z = 2 ' atribuo o valor 2 a variavel z
Dim econtrou As Boolean
encontrou = False 'atribuo falso para a variavel encontrou
Dim pessoaCadastrada As String ' armazena o nome da planilha que você irá deletar
Dim novaformula As String 'armazena formula que vai ser inserida na celula
Dim concatenador As String ' constroi a formula a ser adicionada na celula


'Verificar o erro da planilha ser ter espaços vazios ateh o nome das pessoas

'atribui automaticamente a y um valor igual ao numero de linhas preenchidas na coluna A
'Ex: se na coluna A Temos algo escrito na celula y sera igual a 6
y = Range("A65536").End(xlUp).Row

'deleta todas as pessoas selecionadas
With Selection
.Delete
End With

'desativa o aviso de deleção das planilhas
Application.DisplayAlerts = False

'percorre todas as sheets existentes no workbook
Do While z <= Worksheets.Count

For x = 12 To y 'declarando onde começa e onde termina a variável q usaremos para as linhas

pessoaCadastrada = ActiveSheet.Cells(x, 1).Value 'definindo o nome da nova planilha, "a" é a variável da linha e 1 é a coluna, vc pode mudar isto...

If Sheets(z).Name = pessoaCadastrada Then
encontrou = True
concatenador = concatenador & pessoaCadastrada & "!" & Sheets(pessoaCadastrada).Range("A3").Address & "," 'acumula as celulas que vc quer somar
Exit For
End If

Next

'verifica se encontrou a planilha no cadastro, senao, deleta a planilha
If encontrou = False And z <= Worksheets.Count Then
Sheets(z).Delete
z = z - 1
End If

encontrou = False
z = z + 1

Loop

'constroi a formula que sera imputada na celula
novaformula = "=sum(" & Left(concatenador, Len(concatenador) - 1) & ")"

'inputa a formula na celula desejada, no caso é a A1 da planilha Lista, pois ela é a ActiveSheet(planilha ativa) no momento
ActiveSheet.Range("A1").Value = novaformula

MsgBox "Planilhas Deletadas Com Sucesso !", vbInformation

' ativa o aviso de deleção das planilhas
Application.DisplayAlerts = True

End Sub
**********************************************************************************



Quaisquer dúvidas estou a disposição,

Abs,

Rafael