Macro para nova aba e hyperlink

Clonner · 24 de setembro de 2011

Estou tentando criar uma macro para criar uma nova aba, onde o nome desta aba será o nome que estiver em uma célula (até aqui consegui).

Quero também que após criada a aba a célula passe a ser um hiperlink para esta nova aba.

Trafix · 24 de setembro de 2011

Bom dia, Cloner

Seria muito interessante se disponibilizasse uma planilha fictícia aqui de exemplo.

Att

24 de setembro de 2011

O código abaixo cria uma planilha, nomeia essa planilha conforme o conteúdo de A1 da planilha ativa e cria um "hyperlink" nessa célula para a nova planilha.

Antes, verifica se A1 está vazia e se já existe planilha com o nome colocado em A1.

Sub CriaNomeiaHyper()

Dim planBase, planNova As String
Dim plan As Worksheet, flg As Boolean
    planBase = ActiveSheet.Name
    planNova = ActiveSheet.Range("A1").Value

    If planNova = "" Then
        MsgBox "insira em A1 o nome desejado para a nova planilha"
        Exit Sub
    End If
            For Each plan In Worksheets
                If plan.Name Like planNova Then flg = True: Exit For
            Next
If flg = True Then
    MsgBox "já existe a planilha  " & "'" & _
    planNova & "'" & ",  altere o nome desejado"
Else
    Worksheets.Add(after:=Sheets(Sheets.Count)).Name = planNova
    ActiveSheet.Hyperlinks.Add Anchor:= _
    Sheets(planBase).Range("A1"), Address:="", _
        SubAddress:="'" & ActiveSheet.Name _
            & "'!A1", TextToDisplay:=ActiveSheet.Name
End If

End Sub

Clonner · 26 de setembro de 2011

Obrigado Osvaldo a macro funciona perfeitamente.

Só que agora estou com outro problema.

Sou relativamente novo em VBA e a planilha que estou criando é um banco de dados em excel com gerenciador de relatórios para impressão automática.

Istó é tenho uma aba onde ficaram todos os historicos de analises, uma aba (dados) que é usada como um temporário para a planilha modelo que é o relatório que será impresso e arquivado em uma nova aba com o número de relatório (sem nenhuma fórmula só os dados).

Segue o link da planilha que estou montando

http://www.megaupload.com/?d=34H6GJMH

O botão inserir análise ainda estou fazendo onde ele abrirá um fórmulário e irá inserir os dados na primeira coluna vazia e o botão gerar relatório irá criar o relatório em uma nova aba com base na aba modelo e colocar um link na aba historico.

Espero ter explicado direito. Sei que usei um caminho puco usual como ter uma aba de dados temporária mas foi o que consegui fazer.

Clonner

26 de setembro de 2011

...Só que agora estou com outro problema. ...

Aê, Clonner.

Em que exatamente podemos te ajudar agora?

Clonner · 27 de setembro de 2011

Bem Osvado,

Tentei implementar o código que você vez no que eu mesclei (peguei uns códigos ali e outros aqui) só que não consegui criar o link no lugar certo que seria na aba historico na linha 14, começando na coluna B e a medida que novos dados fossem chegando eles e novas abas criadas o link novo fosse para a coluna C, D e assim por diante.

Valeu mesmo pela ajuda e disposição.

Clonner

Clonner · 28 de setembro de 2011

Osvaldo, consegui resolver o problema criando outra macro baseada na que você me enviou. Sei que deve ter como diminuir o código se você ou alguém puder dar uma olhada eu já agradeço antecipadamente.

Seguem os códigos:

Sub Relatorio()

'

' Relatorio Macro

' Macro gravada em 23/9/2011 por SM Cromatografia

'

Dim Coluna As Long

Dim Linha As Long

Dim Qtd_Linhas As Long

'Seleciona a planilha Historico

Sheets("Historico").Select

'Seleciona (move o cursor) para a celula IV11 na planilha Historico

Range("IV11").Select

'Retorna o cursor para a última coluna que possui dados

Coluna = Selection.End(xlToLeft).Select

'Determinar que se deve contar até a linha 46

Qtd_Linhas = 46

'Determina que o numero da coluna, tanto inicial como final, será o número onde o cursor estiver

Coluna = ActiveCell.Column

'Determina que o numero da linha inicial será o número onde o cursor estiver

Linha = ActiveCell.Row

'Seleciona na planilha Historico a coluna referente a última análise feita

Range(Cells(Linha - 1, Coluna), Cells(Qtd_Linhas, Coluna)).Select

'Copia os dados selecionados

Selection.Copy

'Seleciona a planilha Dados

Sheets("Dados").Select

'Seleciona a célula A11 na planilha ativa Dados

Range("A10").Select

'Cola os resultados copiados na planilha dados

ActiveSheet.Paste

Dim SbCelNome As String, SbObjetos As Object

Dim wshPlan As Worksheet

Dim rnCell As Range

Dim i As Integer

Dim Nome_aba As Integer

'Esta macro copia a planilha ativa e

'exemplar colocado no último lugar do livro.

'sem as formulas somente com os valores

'e sem os objetos(botões)

'Seleciona a planilha Historico

Sheets("Modelo").Select

Application.ScreenUpdating = False

i = Worksheets.Count

ActiveSheet.Copy after:=Worksheets(i)

i = i + 1

Set wshPlan = Worksheets(i)

'Se houver célula com fórmulas na celula

On Error Resume Next

'Converte fórmulas para valores constantes

For Each rnCell In wshPlan.Cells.SpecialCells(xlFormulas)

rnCell.Value = rnCell.Value

Next rnCell

'É uma colecção compreensiva na fórmula planilha pode

'ser mais rápido com o Colar Especial.

'With wshPlan.UsedRange

' .Copy

' .PasteSpecial Paste:=xlValues

'End With

'Application.CutCopyMode = False

'Coloca o numero do relatorio criado na aba

SbCelNome = CStr(Worksheets("Dados").Range("A14").Value)

'Remove o Formulário objeto, valores, e para compartilhar ficha

'seu nome

With wshPlan

For Each SbObjetos In .Shapes

SbObjetos.Delete

Next SbObjetos

.Name = SbCelNome

.Range("B4:B6").Value = ""

.Range("A1").Select

End With

On Error GoTo 0

Application.ScreenUpdating = True

End Sub

Sub Criar_Hyperlink()

Dim SbCelNome As String

'Define o valor de SbCelNome

SbCelNome = CStr(Worksheets("Dados").Range("A14").Value)

'Seleciona a planilha historico

'A ultima celula da linha 14

'Retorna para a primeira coluna com dados

Sheets("Historico").Select

Range("IV14").Select

Selection.End(xlToLeft).Select

'Cria o hyperlink na célula B14 da planilha historico

ActiveSheet.Hyperlinks.Add Anchor:= _

ActiveCell, Address:="", _

SubAddress:="'" & SbCelNome _

& "'!A1", TextToDisplay:=SbCelNome

'Retorna para a última planilha criada

Sheets(SbCelNome).Select

End Sub

Clonner

28 de setembro de 2011

Iaê, clonner.

como recomenda o esquartejador: um pedaço por vez...

inicialmente substitua um grupo de linhas e teste, se funcionar, depois faremos mais um grupo ...

substitua estas linhas

Dim Coluna As Long
Dim Linha As Long
Dim Qtd_Linhas As Long
. . . 
. . . 
. . . 
'Cola os resultados copiados na planilha dados
ActiveSheet.Paste

por estas

    Dim Coluna As Long
    With Sheets("Historico")
        Coluna = .Cells(11, "IV").End(xlToLeft).Column
            .Range(.Cells(10, Coluna), .Cells(46, Coluna)).Copy
            Sheets("Dados").Range("A10").PasteSpecial
        Application.CutCopyMode = False
    End With

Clonner · 29 de setembro de 2011

Beleza Osvaldo.

Fiz a substituição e funcionou perfeitamente!

Cara tive um trabalho danado você fez essa parte bem mais simples.

Sempre fiz macros para a empresa mais essa é bem mais complicada e estou apanhando feio. Estou fazendo agora o formulario para inserir os dados depois posto pro pessoal dar uma olhada.

Obrigado mesmo pela ajuda.

Clonner

2 de outubro de 2011

Aê, clonner.

O código abaixo contém a parte que postei antes e a parte restante, portanto, é o código completo que equivale ao seu (esse foi o objetivo, né, vamos ver se funciona...).

Faça os testes em uma cópia do seu arquivo.

Sub Relatório2()
    Dim Coluna As Long, SbObjetos As Object
Application.ScreenUpdating = False
    With Sheets("Historico")
        Coluna = .Cells(11, "IV").End(xlToLeft).Column
            .Range(.Cells(10, Coluna), .Cells(46, Coluna)).Copy
            Sheets("Dados").Range("A10").PasteSpecial
    End With
Sheets("Modelo").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .UsedRange.Copy
        .UsedRange.PasteSpecial Paste:=xlValues
        .Name = Sheets("Dados").Range("A14").Value
            For Each SbObjetos In .Shapes
                SbObjetos.Select
                SbObjetos.Delete
            Next SbObjetos
        .Range("B4:B6").ClearContents
        .Range("A1").Select
        .Hyperlinks.Add Anchor:= _
Sheets("Historico").[B14], Address:="", _
SubAddress:="'" & ActiveSheet.Name _
            & "'!A1", TextToDisplay:=ActiveSheet.Name
    End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Clonner · 6 de outubro de 2011

Olá Osvaldo, demorei pra postar dessa vez hein!

Bem implantei o código e na primeira tentativa apareceu o seguinte erro:

---> "Não é possivel alterar parte de uma céula mesclada"

Quando pedi para Depurar:

Sub Relatorio()

Dim Coluna As Long, SbObjetos As Object

Application.ScreenUpdating = False

With Sheets("Historico")

Coluna = .Cells(11, "IV").End(xlToLeft).Column

.Range(.Cells(10, Coluna), .Cells(46, Coluna)).Copy

Sheets("Dados").Range("A10").PasteSpecial

End With

Sheets("Modelo").Copy after:=Sheets(Sheets.Count)

With ActiveSheet

.UsedRange.Copy

.UsedRange.PasteSpecial Paste:=xlValues

.Name = Sheets("Dados").Range("A14").Value

For Each SbObjetos In .Shapes

SbObjetos.Select

SbObjetos.Delete

Next SbObjetos

.Range("B4:B6").ClearContents ( Aqui estava o erro)

.Range("A1").Select

.Hyperlinks.Add Anchor:= _

Sheets("Historico").[b14], Address:="", _

SubAddress:="'" & ActiveSheet.Name _

& "'!A1", TextToDisplay:=ActiveSheet.Name

End With

Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

Solução: alterei para ".Range("B4:B5").ClearContents" e funcionou

Quando corri o código novamente (supondo que o usuário repetisse o mesmo nº de relatório) aparece o seguinte erro:

---> "Não é possível renomear uma planilha com o mesmo nome de uma planilha já existente, uma biblioteca de objetos ou pasta de trabalho referenciada pelo Visual basic"

Esse não consegui solucionar, estava tentando implemetar uma mensagem informando que o nº de relatório já existe ou solicitar um número novo atraves de TextBox.

Talvez fosse mais prático quando clicar em gerar relatório ele solicitasse o nº de relatório, através de um text box e colocasse na coluna correspondente.

Ainda não terminei a macro para inserir análise (esse assunto é para outro tópico), mas o arquivo está ficando ótimo.

Muito obrigado pela ajuda.

Clonner

Outro problema que apareceu foi o hiperlink que não estava acompanhando as colunas e corrigi alterando inserindo:

.Hyperlinks.Add Anchor:= _

Sheets("Historico").[b14].End(xlToRight), Address:="", _

SubAddress:="'" & ActiveSheet.Name _

& "'!A1", TextToDisplay:=ActiveSheet.Name

Clonner

7 de outubro de 2011

adicionei instruções para impedir que seja feita a cópia da planilha se o nome a ser atribuído a ela já existir no arquivo e tb impede a cópia se a célula na qual estaria o nome estiver em branco... testaí...

Sub Relatório3()
    Dim Coluna As Long, SbObjetos As Object
    Dim plan As Worksheet, nome As String
Application.ScreenUpdating = False
    With Sheets("Historico")
        Coluna = .Cells(11, "IV").End(xlToLeft).Column
            nome = .Cells(14, Coluna).Value
                If nome = "" Then
                    MsgBox "insira um nome para a nova planilha"
                    Exit Sub
                End If
    For Each plan In Worksheets
        If InStr(1, plan.Name, nome) = 1 Then
            MsgBox "já existe planilha com esse nome, altere"
            Exit Sub
        End If
    Next plan
            .Range(.Cells(10, Coluna), .Cells(46, Coluna)).Copy
            Sheets("Dados").Range("A10").PasteSpecial
    End With
Sheets("Modelo").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .UsedRange.Copy
            .UsedRange.PasteSpecial Paste:=xlValues
                .Name = nome
                    For Each SbObjetos In .Shapes
                        SbObjetos.Select
                            SbObjetos.Delete
                        Next SbObjetos
                    .Range("B4:B6").ClearContents
                .Range("A1").Select
            .Hyperlinks.Add Anchor:= _
        Sheets("Historico").[B14], Address:="", _
                SubAddress:="'" & ActiveSheet.Name _
                    & "'!A1", TextToDisplay:=ActiveSheet.Name
    End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Clonner · 11 de outubro de 2011

Olá Osvaldo,

O código funciona perfeitamente e ficou muito, mas muito mais enxuto, Obrigado. Só inclui aquela alteração no hyperlink para ele seguir a coluna especifica e não ficar sempre na B14.

Já preparei o formulario para inserir os dados, estou tendo problema com TextBox.

A célula de destino está formatada para data e quando insiro os dados via formulario (com uma Text.Box) ocorre uma mudança na data. Existe alguma maneira de formatar um Text.Box para o formato dd/mm/aa?

Mais uma vez Obrigado.

Segue abaixo o código do do fórmulario:

Private Sub CommandButton1_Click()
Dim Coluna As Long

Coluna = Sheets("Historico").Cells(14, "IV").End(xlToLeft).Column

Sheets("Historico").Cells(9, Coluna + 1).Value = TextBox1.Text 'Resp Coleta

Sheets("Historico").Cells(10, Coluna + 1).Value = TextBox2.Text 'Resp Pagamento

Sheets("Historico").Cells(11, Coluna + 1).Value = TextBox3.Text 'coleta

Sheets("Historico").Cells(12, Coluna + 1).Value = TextBox4.Text 'Análise

Sheets("Historico").Cells(13, Coluna + 1).Value = TextBox5.Text 'Recebimento

Sheets("Historico").Cells(16, Coluna + 1).Value = TextBox6.Text 'Doc Referencia

Sheets("Historico").Cells(17, Coluna + 1).Value = ComboBox7.Text 'operando

Sheets("Historico").Cells(18, Coluna + 1).Value = TextBox8.Text 'T óleo

Sheets("Historico").Cells(19, Coluna + 1).Value = TextBox9.Text 'T enrolamento

Sheets("Historico").Cells(20, Coluna + 1).Value = TextBox10.Text 'Sílica

Sheets("Historico").Cells(21, Coluna + 1).Value = TextBox28.Text 'Observação

Sheets("Historico").Cells(22, Coluna + 1).Value = TextBox27.Text 'S Corrosivo

Sheets("Historico").Cells(23, Coluna + 1).Value = TextBox18.Text 'PCB/Askarel

Sheets("Historico").Cells(24, Coluna + 1).Value = ComboBox11.Text 'Aspecto

Sheets("Historico").Cells(25, Coluna + 1).Value = TextBox19.Text 'Cor

Sheets("Historico").Cells(26, Coluna + 1).Value = TextBox12.Text 'Acidez

Sheets("Historico").Cells(27, Coluna + 1).Value = TextBox23.Text 'Rigidez 6869

Sheets("Historico").Cells(28, Coluna + 1).Value = TextBox13.Text 'Rigidez 60156

Sheets("Historico").Cells(29, Coluna + 1).Value = TextBox14.Text 'Teor água

Sheets("Historico").Cells(31, Coluna + 1).Value = TextBox15.Text 'TI

Sheets("Historico").Cells(32, Coluna + 1).Value = TextBox16.Text 'Densidade

Sheets("Historico").Cells(33, Coluna + 1).Value = TextBox21.Text 'FP 25

Sheets("Historico").Cells(34, Coluna + 1).Value = TextBox22.Text 'FP 90

Sheets("Historico").Cells(35, Coluna + 1).Value = TextBox17.Text 'FP 100

Sheets("Historico").Cells(36, Coluna + 1).Value = TextBox20.Text 'DBPC

Sheets("Historico").Cells(37, Coluna + 1).Value = TextBox24.Text 'Visc 40

Sheets("Historico").Cells(38, Coluna + 1).Value = TextBox25.Text 'Visc 100

Sheets("Historico").Cells(39, Coluna + 1).Value = TextBox26.Text 'Pt Fulgor

Inserir_Analise.Hide

End Sub