Saberexcel - site das macros

Essa macro do Aplicativo microsoft Excel VBA(Visual Basic Application), abre a caixa de diálogo Abrir e insere um shapes(autoforma) na folha de planilha ligada automaticamente a um macro, como mostra macros abaixo.


Sub Abre_determinada_imagens()
On Error Resume Next ' caso nao selecione nada
vCaminho = Application.GetOpenFilename("Planilhas imagens - Saberexcel (*.jpg;*.jpeg;*.gif), *.jpg;*.gif;*.jpeg,Todas (*.*), *.*", Empty, "Adicionar Imagem", Empty, Empty)
ActiveSheet.Pictures.Insert(vCaminho).Select
Selection.ShapeRange.AlternativeText = vCaminho
Selection.Name = "sbx"
Selection.OnAction = "Clic_imagem"

End Sub

Sub Clic_imagem()
MsgBox ("Imagem inserida e ligada à um macro"), vbInformation, "Saberexcel - site das macros"
End Sub



Aprenda tudo sobre o Aplicativo microsoft Excel VBA(Visual Basic Application), praticando com os produtos didáticos Saberexcel

Saberexcel - site das Macros

Essas macros do Aplicativo Microsoft Excel VBA(Visual Basic Application), adiciona Shapes(Autoformas) retangulares de forma aleatória na folha de planilha.

Option Explicit

Private Type ExcelShapes
vTipo As Integer
vCarregar As Single
vCores As Long
vRange As Range
vRegiaoTamanho As Single
vRangeSobrePosicao As Boolean
End Type

Private vFomaShapes As ExcelShapes
Private numRotations As Integer

Sub Adicionar_Autoformas()
Dim RngVERMELHO As Integer, RngVERDE As Integer, RngAZUL As Integer
'...................'
'Aleatoriamente acrescenta um dos cinco formas possíveis de retangulos.

'...................'
deleta_shapes
Randomize
RngVERMELHO = Int(Rnd * 256)
RngVERDE = Int(Rnd * 256)
RngAZUL = Int(Rnd * 256)
'...................'
'Inicializar propriedades comuns dos locais que compõem todas as formas.

'...................'
vFomaShapes.vTipo = Int(5 * Rnd) + 1
vFomaShapes.vCarregar = 0.5
vFomaShapes.vCores = RGB(RngVERMELHO, RngVERDE, RngAZUL)
vFomaShapes.vRegiaoTamanho = Range("F3").Width
'...................'
'Inicializar o local da forma, então, construí-la
'...................'
IncializeShapes
Criar_Shapes
'If vFomaShapes.vRangeSobrePosicao Then Fimr
[G1].Select
End Sub


Private Sub IncializeShapes()
'...................'
'select case incializa as formas suspensas nos conjuntos de células
'...................'
Select Case vFomaShapes.vTipo
Case Is = 1
Set vFomaShapes.vRange = Range("F3:I3")
Case Is = 2
Set vFomaShapes.vRange = Range("G3:H4")
Case Is = 3
Set vFomaShapes.vRange = Range("F3:H3,H4")
Case Is = 4
Set vFomaShapes.vRange = Range("F3:H3,G4")
Case Is = 5
Set vFomaShapes.vRange = Range("G3:H3, F4:G4")
End Select
End Sub

Private Sub Criar_Shapes()
Dim I As Integer
Dim NovoShapes As Shapes
Dim c As Range
'...................'
'criando um conjunto de quatro retangulos.
'...................'
I = 1
Set NovoShapes = ActiveSheet.Shapes
For Each c In vFomaShapes.vRange
NovoShapes.AddShape(msoShapeRectangle, c.Left, c.Top, _
c.Width, c.Height).Select
Selection.ShapeRange.Line.Weight = vFomaShapes.vCarregar
Selection.ShapeRange.Fill.ForeColor.RGB = vFomaShapes.vCores
Selection.ShapeRange.Name = "Saberexcel" & I
I = I + 1
Next
'...................'
'Verifica se sobrepõe forma, adicionou formas existentes
'...................'
For Each c In vFomaShapes.vRange
If c.Value = "x" Then
vFomaShapes.vRangeSobrePosicao = True
Exit For
End If
Next
End Sub
'...................'

Sub deleta_shapes()
Range("G1").Select
ActiveSheet.Shapes.Range(Array("Saberexcel4", "Saberexcel1")).Select
ActiveSheet.Shapes.Range(Array("Saberexcel4", "Saberexcel1", "Saberexcel2")).Select
ActiveSheet.Shapes.Range(Array("Saberexcel4", "Saberexcel1", "Saberexcel2", "Saberexcel3")). _
Select
Selection.Delete
End Sub



Aprenda tudo sobre o Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos SaberExcel

Saberexcel - site das macros

Essa macro do Aplicativo Microsoft Excel VBA(Visual Basic Application), insere na folha de planilha autoformas um autoformas(shape) na cor marrom gradiente(Degradê)

Sub Inserindo_shapes_degrade_planilha()

Set vDoc = Worksheets(1)

With vDoc.Shapes.AddShape(msoShapeRectangle, _
90, 90, 90, 50).Fill
.ForeColor.RGB = RGB(128, 0, 0)
.BackColor.RGB = RGB(170, 170, 170)
.TwoColorGradient msoGradientHorizontal, 1
End With

End Sub

Aprenda tudo sobre o Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel

Saberexcel - o site de quem precisa aprender Macros Microsoft Excel VBA

Essas macros do Aplicativo Microsoft Excel VBA(Visual Basic Application), juntamente com shapes em forma de (Semafóros) com os sinais vazados para mostrar a FC(Formatação condicional) em determinadas células na folha de planilha, mostra as cores 'Vermelha, Amarela e Verde', limitando intervalos de números representados por porcentagem.

FC - Formatação condicional atribuida à coluna(Q) - a cada 3 células

Fórmulas usadas na caixa de diálogo (FC-Formatação Condicional)

Fórmula usada primeira condição .....: =O7<=ÍNDICE(Limites;2;2)
Fórmula usada segunda condição .....: =E(O7>ÍNDICE(Limites;2;2);O7<ÍNDICE(Limites;3;2))
Fórmula usada terceira condição ......: =E(O7>ÍNDICE(Limites;3;2);O7<ÍNDICE(Limites;4;2)

Imagem da planilha com os shapes (Semaforos) x (Porcentagem)





Essas macros usadas abaixo foi somente para Ilustrar o exemplo para mostrar as imagens desejadas,
eu uso muito essas macros que são muto boas para mostrarmos determinados shapes desejados,
observe que essas macros ocultam o shapes e mostram somente a imagem(shapes) desejado.
Essas macros são retirnadas da nossa Coleção de 15.000 Macros Microsoft Excel VBA, Fórmulas e Funções,
que são excelentes para pesquisas e treinamento VBA.


Coleção 15.000 Macros Microsoft Excel VBA Fórmulas e Funções

Sub Oculta_Shapes()
For i = 1 To 3
On Error Resume Next
With ActiveSheet
.Shapes("saber" & i).Visible = False
End With
Next
[A1].Select
End Sub

'oculta todos os shapes, cujo nome inicia-se com saber(...) e mostra somente o saber1
Sub fc_semafaro_1()
Oculta_Shapes ' vai ocultar todos os shapes que inicia-se com 'saber'
Saber1.Shapes("saber1").Visible = True
End Sub

'Oculta todos os shapes, cujo nome inicia-se com saber(...) e mostra somente o saber2
Sub fc_semafaro2()
Oculta_Shapes ' vai ocultar todos os shapes que inicia-se com 'saber'
Saber1.Shapes("saber2").Visible = True
End Sub

'Oculta todos os shapes, cujo nome inicia-se com saber(...) e mostra somente o saber2
Sub fc_semafaro3()
Oculta_Shapes ' vai ocultar todos os shapes que inicia-se com 'saber'
Saber1.Shapes("saber3").Visible = True
End Sub

Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel

Publicidade
Compre com segurança, garantia e ótimos preços

Saberexcel - o site de quem precisa aprender Microsoft Excel VBA

Esse macro do Aplicativo Microsoft Excel VBA(Visual Basic Application), insere um Shapes(Autoforma) com determinadas medidas, na folha de planilha, contendo as palavras abaixo determinados pelo macro, fazendo um número de interações determinado pela constante Maximo_interacoes, essas palavras são repetidas no proprio shapes(autoforma), esses números de vezes que são determinados pelo loop ao número de interações desejadas.
Observe que aproveitei o exemplo para inserir um contador na célula(A1) e nesta célula vinculei um tipo de barra de progressão bem interessante,
ligada à uma Função

Public Sub Loop_insere_palavra_shapes()

Dim vPlans As Excel.Worksheet
Dim vShapes As Shape
Dim vFrame As TextFrame
Dim i As Long

Const Incio_Texto As String = "Aprender VBA Saberexcel, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, " _
& "Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, " _
& "Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Prática, Treinamento é tudo no aprendizado!."
Const Maximo_interacoes As Long = 200
MsgBox Len(Incio_Texto)

Set vPlans = ThisWorkbook.Sheets("Loop_palavras_repetidas_shapes")
Set vShapes = vPlans.Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 50, 500, 1000)
Set vFrame = vShapes.TextFrame

'Debug.Print TypeName(vShapes), vShapes.Name'
vFrame.Characters.Text = Incio_Texto
'vFrame.AutoSize = True


For i = 1 To Maximo_interacoes
Inserir_EsteTexto vFrame, " Saberexcel_VBA_Treinamento®"
Range("A1").Value = i
Next i
'
End Sub

Private Sub Inserir_EsteTexto(vFrame As TextFrame, _
vstrTexto As String)
Dim strRight As String
Dim i As Long

With vFrame
For i = 0 To Int(Len(vstrTexto) / 254)
strRight = .Characters(.Characters.Count).Text
.Characters(.Characters.Count).Insert strRight & Mid(vstrTexto, (i * 254) + 1, 254)
'Debug.Print Len(vstrTexto), .Characters.Count'
Next i
End With

End Sub


Essa macro abaixo é uma macro auxliar para ajudar no teste com o macro acima, sua função deletar shapes retangulares.

Sub Deleta_Shapes_retangulares()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.AutoShapeType = msoShapeRectangle Then
On Error Resume Next
If Intersect(shp.TopLeftCell, Selection.Range) Then shp.Delete
'Intersect(shp.BottomRightCell),Selection.Range) Then shp.Delete
End If
Next shp
[A1].Value = ""

End Sub

Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel





Publicidade
Compre com segurança, garantia e ótimos preços