Planilha Excel VBA barra ferramenta chama macros utilitários

Planilha Excel vba shapes 6 retorna valor celula

Planilha Excel VBA barra ferramenta chama macros utilitários Estes Macros do aplicativo Microsoft Excel VBA(Visual Basic Application) cria uma barra de ferramente com vários itens de menus que podem servir como utilitário e ou você poderá separá-los, em planilhas para seu treinamento com vba.
uma boa planilha para treinamento de como criar uma barra de ferramenta personalizada chamando macros.

Sub auto_open()
sba_barra_botoes
sbb_barra_listar_nomes_range
End Sub
‘//============’
Sub sba_barra_botoes()
Dim barra As CommandBar
Dim botao As CommandBarControl
On Error Resume Next
CommandBars(“sbx-barraUltilitarios”).Delete
Set barra = CommandBars.Add(Name:=”sbx-barraUltilitarios”)
barra.Visible = True

Set botao = CommandBars(“sbx-barraUltilitarios”).Controls.Add(Type:=msoControlButton)
botao.BeginGroup = True
botao.Style = msoButtonCaption
botao.OnAction = “sbx_soma_valores”
botao.Caption = “|Somar Meses”

Set botao = CommandBars(“sbx-barraUltilitarios”).Controls.Add(Type:=msoControlButton)
botao.BeginGroup = True
botao.Style = msoButtonCaption
botao.OnAction = “sbc_bordas”
botao.Caption = “|Bordas”

Set botao = CommandBars(“sbx-barraUltilitarios”).Controls.Add(Type:=msoControlButton)
botao.BeginGroup = True
botao.Style = msoButtonCaption
botao.OnAction = “sbd_lista_nomes_range”
botao.Caption = “|Lista Nomes Range”

Set botao = CommandBars(“sbx-barraUltilitarios”).Controls.Add(Type:=msoControlButton)
botao.BeginGroup = True
botao.Style = msoButtonCaption
botao.OnAction = “sbd_deletar_nomes_range_plan”
botao.Caption = “|Deletar Nomes RangePlan”

Set botao = CommandBars(“sbx-barraUltilitarios”).Controls.Add(Type:=msoControlButton)
botao.BeginGroup = True
botao.Style = msoButtonCaption
botao.OnAction = “sba_converte_data_aammdd”
botao.Caption = “Converte Data AAMMMDD”
barra.Width = barra.Width / 4
End Sub
‘//============’
Sub auto_close()
On Error Resume Next
ActiveWindow.Visible = True
‘Windows(ThisWorkbook.Name).Visible = True
End Sub
‘//============’
Sub sba_converte_data_americana()
For Each c In Selection
If Not c.HasFormula Then
c.Value = c.Value
End If
Next c
End Sub
‘//============’
Sub sba_converte_data_aammdd()
For Each c In Selection
On Error Resume Next
If IsDate(DateSerial(Left(c, 4), Mid(c, 3, 2), Right(c, 2))) Then
If Err = 0 Then c.Value = DateSerial(Left(c, 4), Mid(c, 3, 2), Right(c, 2))
End If
Next c
End Sub
‘//============’
Sub sba_maiuscula()
For Each sbx In Selection
If Not sbx.HasFormula Then
sbx.Value = UCase(sbx.Value)
End If
Next sbx
End Sub
‘//============’
Sub sba_minuscula()
For Each sbx In Selection
If Not sbx.HasFormula Then
sbx.Value = LCase(sbx.Value)
End If
Next sbx
End Sub
‘//============’
Sub sba_nomes_proprios()
For Each sbx In Selection
If Not sbx.HasFormula Then
sbx.Value = Application.Proper(sbx.Value)
End If
Next sbx
End Sub
‘//============’
Sub sba_nomes_proprios_x()
For Each sbx In Selection
If Not sbx.HasFormula Then
sbx.Value = fNomeProprio2(sbx.Value)
End If
Next sbx
End Sub
‘//============’
Sub sba_nomes_proprios1()
For Each sbx In Selection
If Not sbx.HasFormula Then sbx.Value = UCase(Left(sbx, 1)) & LCase(Mid(sbx, 2))
Next sbx
End Sub
‘//============’
Sub sba_deletar_espacos()
For Each sbx In Selection
If Not sbx.HasFormula Then
sbx.Value = Application.Trim(sbx.Value)
End If
Next sbx
End Sub
‘//============’
Sub sba_substituir_ponto()
For Each sbx In Selection
If Not sbx.HasFormula Then
sbx.Value = sbx.Value
End If
Next sbx
End Sub
‘//============’
Sub sba_calendario_abrir()
frmCALENDARIO.Show vbModeless
frmCALENDARIO.Left = 1
frmCALENDARIO.Top = 1
End Sub
‘//============’
Sub sba_calendario_abrir2()
frmCALENDARIO2.Show vbModeless
frmCALENDARIO2.Left = 1
frmCALENDARIO2.Top = 1
End Sub
‘//============’
Sub sba_soma_hiper_link()
On Error Resume Next
Err = 0
Sheets(“Principal”).Select
If Err <> 0 Then
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = “Principal”
ActiveSheet.Tab.ColorIndex = 3
On Error GoTo 0
Range(“c4”) = “Soma”
ActiveWindow.DisplayGridlines = False
Range(“c4”).Font.Bold = True
Range(“c4”).Font.Size = 12
Range(“c4”).Select
Range(“A1”) = Date
Range(“c1”).Select
End If
‘- – – – – – – – – – – –
Range(“c6″).Select
For i = 2 To Sheets.Count
x = Sheets(i).Name
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=””, SubAddress:=”‘” & x & “‘” & “!A1”, TextToDisplay:=x
ActiveCell.Offset(1, 0).Select
Next i
End Sub
‘//============’
Sub sba_hiper_link_ordem()
On Error Resume Next
Err = 0
Sheets(“Accueil”).Select
If Err <> 0 Then
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = “Accueil”
ActiveSheet.Tab.ColorIndex = 3
On Error GoTo 0
Range(“c4”) = “Soma”
ActiveWindow.DisplayGridlines = False
Range(“c4”).Font.Bold = True
Range(“c4”).Font.Size = 12
Range(“c4”).Select
Range(“A1”) = Date
Range(“c1”).Select
End If
‘—–
Range(“c6″).Select
For i = 2 To Sheets.Count
x = Sheets(i).Name
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=””, SubAddress:=”‘” & x & “‘” & “!A1”, TextToDisplay:=x
ActiveCell.Offset(1, 0).Select
Next i
‘— ordenar
If Not IsEmpty(Range(“c7”)) Then
Range(“c6”).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range(“c6”), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End If
‘–
End Sub
‘//============’
Function fNomeProprio2(nom As String)
vTemp = Application.Proper(Application.Trim(nom))
tbl = Array(“De “, “Du “, “Des “, “Le “, “La “, “À “, _
“Em “, “Ou “, “Bis “, “Ter “, “D'”, “L'”, “Avenida “, “Rua “, “R “, “Av “, “Pl “, “Todos “)
For i = 0 To UBound(tbl)
vTemp = Replace(vTemp, tbl(i), LCase(tbl(i)))
Next i
‘—
p = InStr(vTemp, “‘”) ‘ Posição de ‘
If p > 0 Then
If Mid(vTemp, p – 2, 1) <> ” ” Then
Mid(vTemp, p + 1, 1) = LCase(Mid(vTemp, p + 1, 1))
End If
End If
fNomeProprio2 = vTemp
End Function
‘//============’
Sub sba_ordenar_dados()
Dim a(256)
n = Sheets.Count
For i = 1 To n
a(i) = Sheets(i).Name
Next i
‘—- tri
For i = 1 To n
For j = i To n
If a(j) < a(i) Then
vTemp = a(j)
a(j) = a(i)
a(i) = vTemp
End If
Next j
Next i
‘—
For i = 1 To n
Sheets(a(i)).Move before:=Sheets(i)
Next i
Sheets(1).Select
End Sub
‘//============’
Sub sba_deletar_linhas_vazias_colA()
ActiveSheet.Range(“A:A”).SpecialCells(xlCellTypeBlanks).EntireRow.Select
End Sub
‘//============’
Sub sba_nomes_range_shapes()
On Error Resume Next
For Each s In ActiveSheet.Shapes
If Left(s.Name, 2) = “x_” Then s.Delete
Next s
For Each n In ActiveWorkbook.Names
p = InStr(n, ActiveSheet.Name)
If p > 0 Then
p1 = InStr(n, “!”)
p2 = InStr(n, “:”)
If p2 > 0 Then
c = Mid(n, p1 + 1, p2 – p1 – 1)
Else
c = n
End If
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, Len(n.Name) * 7, 10).Select
Selection.Font.Name = “Verdana”
Selection.Font.Size = 8
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 13
nom = “x_” & n.Name
Selection.Name = nom
ActiveSheet.Shapes(nom).Left = Range(c).Left
t = IIf(Range(c).Row > 1, Range(c).Offset(-1, 0).Top, Range(c).Top)
ActiveSheet.Shapes(nom).Top = t
ActiveSheet.Shapes(nom).TextFrame.Characters.Text = n.Name
End If
Next n
End Sub
‘//============’
Sub sba_nome_range_cmt()
On Error Resume Next
For Each n In ActiveWorkbook.Names
p = InStr(n, ActiveSheet.Name)
If p > 0 Then
p1 = InStr(n, “!”)
p2 = InStr(n, “:”)
If p2 > 0 Then
sbx = Mid(n, p1 + 1, p2 – p1 – 1)
Else
sbx = n
End If
If Range(sbx).NoteText = “” Then
Range(sbx).AddComment n.Name ‘& “:” & n
With Range(sbx).Comment.Shape.OLEFormat.Object.Font
.Name = “verdana”
.Size = 8
.FontStyle = “Normal”
.ColorIndex = 5
End With
Range(sbx).Comment.Visible = True
Range(sbx).Comment.Shape.Select
Selection.AutoSize = True
End If
End If
Next n
End Sub
‘//============’
Sub sba_gerenciar_nome_range()
For Each n In ActiveWorkbook.Names
On Error Resume Next
Range(n.Name).BorderAround Weight:=xlMedium
Next n
End Sub
‘//============’
Sub sba_mostrar_formula_cmt()
On Error Resume Next
For Each sbx In Selection
If sbx.HasFormula = True Then
If sbx.NoteText = “” Then
sbx.AddComment sbx.FormulaLocal
With sbx.Comment.Shape.OLEFormat.Object.Font
.Name = “verdana”
.Size = 8
.FontStyle = “Normal”
.ColorIndex = 3
End With
sbx.Comment.Visible = True
sbx.Comment.Shape.Select
Selection.AutoSize = True
End If
End If
Next sbx
End Sub
‘//============’
Sub sba_deletar_comentario()
On Error Resume Next
Selection.ClearComments
End Sub
‘//============’
Sub sba_ocultar_comentario()
On Error Resume Next
For Each sbx In ActiveSheet.Comments
sbx.Visible = False
Next sbx
End Sub

Sub sba_mostrar_formulas()
On Error Resume Next
For Each sbx In ActiveSheet.Comments
sbx.Visible = True
Next sbx
End Sub

‘//============’
Sub sba_cmt_mostrar_formulas()
If ActiveCell.Formula = “” Or ActiveCell.HasFormula = False Then Exit Sub
Set sbx = ActiveCell
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 1, 1, Len(sbx.Formula) * 5, 10).Select
Selection.Characters.Text = c.FormulaLocal
Selection.Font.Name = “Arial”
Selection.Font.Size = 8
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 13
vNome = “Shape” & sbx.Row & sbx.Column
Selection.Name = vNome
ActiveSheet.Shapes(vNome).Left = ActiveCell.Offset(0, 1).Left + 3
ActiveSheet.Shapes(vNome).Top = ActiveCell.Top + 1
End Sub
‘//============’
Sub sba_impressao_busca()
If Selection.Count < 10 Then
MsgBox “selecionar um nome range ‘campo’!”
Exit Sub
End If
feuilleActive = ActiveSheet.Name
vMemoriza = ActiveCell.Address
vMemorizaChamp = Selection.Address
Selection.CopyPicture ‘ Copie la zone
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = “vTemp”
ActiveSheet.Paste Destination:=ActiveSheet.Range(vMemoriza) ‘crée un shape
ActiveSheet.PageSetup.PrintArea = vMemorizaChamp
ActiveWindow.SelectedSheets.PrintPreview
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Delete
Application.DisplayAlerts = False
Sheets(“vTemp”).Delete
Sheets(feuilleActive).Select
End Sub
‘//============’
Sub sba_exportar_imagem_gif()
Arquivo = ActiveWorkbook.Path & “\” & “minha_imagem.gif”
Saber3.Select
Saber3.[e10:h21].Select
Selection.CopyPicture
ActiveSheet.Paste Destination:=Range(“A1″) ‘criar um shapes (autoforma)
Set s = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
s.Copy
With ActiveSheet
.ChartObjects.Add(0, 0, s.Width, s.Height * 1.15).Chart.Paste
.ChartObjects(1).Border.LineStyle = 0
.ChartObjects(1).Chart.Export Filename:=Arquivo, FilterName:=”gif”
.Shapes(ActiveSheet.Shapes.Count).Delete
.Shapes(ActiveSheet.Shapes.Count).Delete
End With
MsgBox (“imagem gif da celula(A1) foi enviada para o seu desktop”), vbInformation, “Escola Saberexcel VBA Estudos”
End Sub

‘//============’
Sub sba_deletar_planilhas_vazias()
Application.DisplayAlerts = False
For Each s In ActiveWorkbook.Worksheets
s.Activate
Selection.SpecialCells(xlLastCell).Select ‘ dernière cellule du tableau
If ActiveCell.Address = “$A$1” And IsEmpty(Range(“a1”)) Then
ActiveSheet.Delete
End If
Next s
End Sub
‘//============’
Public Function Arredondar(Valor As Variant, Optional NumDec) As Double
If IsMissing(NumDec) Then ‘argument NumDec absent
NumDec = 0
End If
If IsNull(Valor) Then
Arredondar = 0
Else
Arredondar = Int((Valor * (10 ^ NumDec) + 0.5)) / (10 ^ NumDec)
End If
End Function

Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Escola Saberexcel VBA Estudos® – Treinamentos com Macros, Fórmulas e Funções.