Adicionado em: | 03/05/2011 |
Modificado em: | 03/05/2011 |
Tamanho: | Vazio |
Downloads: | 906 |
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
Adicionado em: | 23/06/2012 |
Modificado em: | 23/06/2012 |
Tamanho: | Vazio |
Downloads: | 761 |
Escola Saberexcel VBA Estudos® - Treinamento com Macros, Fórmulas e Funções
Esses macros do Aplicativo Microsoft Excel VBA(Visual Basic Application), insere um shapes(Autoforma) personalizado, usei neste exemplo
uma formatação do shapes - usando o GM(Gravador de Macros) fiz com finalidade didática a formatação de determinadas letras na folha de
planilha, quero que voces observem o poder do GM(Gravador de Macros) que não precisei programar uma só silaba. GM(Gravador de Macros) é o primeiro tema do nosso Curso Completo Microsoft Excel VBA .
Espero que o exemplo possam lhe ser útil.
fiquem todos com Deus, Expedito Marcondes
Sub sbx_inserir_shapes_personalizado()
On Error Resume Next
ActiveSheet.Shapes.Range(Array("sbx_1")).Delete
ActiveSheet.Shapes.AddTextEffect _
(msoTextEffect1, "Escola SaberExcel VBA Estudos®", _
"Verdana", 40#, msoFalse, _
msoFalse, 130, 205).Select
Selection.ShapeRange.Name = "sbx_1"
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 36
Selection.ShapeRange.Fill.Transparency = 0.5
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange.IncrementRotation -26.69
[L1].Select
Application.Wait Now + TimeValue("00:00:03") 'pausa para execução da proxima macro
sbx_cores_sbx
End Sub
Sub sbx_deletar_shapes()
On Error GoTo sbxerro
ActiveSheet.Shapes.Range(Array("sbx_1")).Delete
Exit Sub
sbxerro: MsgBox ("não há shapes para deletar, insira primeiro"), vbCritical, "Escola Saberexcel VBA Estudos®"
End Sub
Sub sbx_cores_sbx()
ActiveSheet.Shapes.Range(Array("sbx_1")).Select
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(8, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(8, 1).Font
.NameComplexScript = "Old English Text MT"
.NameFarEast = "Old English Text MT"
.Name = "Old English Text MT"
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(9, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 192, 0)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(10, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 240)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(11, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(12, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(13, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 0)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(13, 1).Font
.NameComplexScript = "Old English Text MT"
.NameFarEast = "Old English Text MT"
.Name = "Old English Text MT"
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(14, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(15, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(16, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 240)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(17, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 0)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(19, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(20, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(21, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 240)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(30, 1).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 192, 0)
.Transparency = 0
.Solid
End With
Range("I3").Select
End Sub
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.
Baixe o exemplo de planilha contendo os macros acima
Adicionado em: | 18/02/2011 |
Modificado em: | 18/02/2011 |
Tamanho: | Vazio |
Downloads: | 739 |
Saberexcel - o site das macros
Essas macros do Aplicativo Microsoft Excel VBA(Visual Basic Application), verificam na folha de planilha excel se existe ou não shapes, caso existe retorna uma mensagem informando o endereço das células onde estão localizadas, caso não exista, emite uma mensagem da inexistência de shapes e ou imagem na folha de planilha.
Sub verifica_se_existe_imagem_na_panilha_I()
Dim vLocal$, Shp As Shape, c%
For Each Shp In ActiveSheet.Shapes
If Shp.Type = msoPicture Then
vLocal = vLocal & Shp.TopLeftCell.Address & " : " & Shp.Name & vbCrLf
c = 1
End If
Next
If c = 1 Then
MsgBox "Células que contém imagens são:" & vbCrLf & "[" & vLocal & "]", _
vbInformation, "Saberexcel - site das macros"
Else
MsgBox "Não há imagens nesta folha de planilha!", _
vbInformation, "Saberexcel - site das macros"
End If
End Sub
Essa macro também verifica se há shapes(autoformas ou imagens) e retorna uma msg, indicando o endereço das células que contém as imagem
Sub verifica_se_existe_imagem_na_panilha_II()
Dim Shp As Shape, vArea As Range
For Each Shp In ActiveSheet.Shapes
If vArea Is Nothing Then
Set vArea = Shp.TopLeftCell
Else
Set vArea = Union(vArea, Shp.TopLeftCell)
End If
Next Shp
MsgBox "Há imagems shapes(autoformas) nas células : [ " & vArea.Address(0, 0) & " ]", _
vbInformation, "Saberexcel - site das macros"
End Sub
Aprenda tudo sobre o Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel
Adicionado em: | 10/03/2011 |
Modificado em: | 10/03/2011 |
Tamanho: | Vazio |
Downloads: | 692 |
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
Adicionado em: | 10/03/2011 |
Modificado em: | 10/03/2011 |
Tamanho: | Vazio |
Downloads: | 680 |
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
Adquira já o Acesso Imediato
à Area de Membros
Aprenda Excel VBA com Simplicidade de
códigos e Eficácia, Escrevendo Menos e
Fazendo Mais.
'-------------------------------------'
Entrega Imediata:
+ 500 Video Aulas MS Excel VBA
+ 35.000 Planilhas Excel e VBA
+ Coleção 25.000 Macros MS Excel VBA
+ 141 Planilhas Instruções Loops
+ 341 Planilhas WorksheetFunctions(VBA)
+ 04 Módulos Como Fazer Excel VBA
+ Curso Completo MS Excel VBA
+ Planilhas Inteligentes
<script type="text/javascript"><!--
google_ad_client = "ca-pub-2317234650173689";
/* retangulo 336 x 280 */
google_ad_slot = "0315083363";
google_ad_width = 336;
google_ad_height = 280;
//-->
</script>
<script type="text/javascript"
src="http://pagead2.googlesyndication.com/pagead/show_ads.js">
</script>
Aprenda tudo sobre o Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel,
Sobre as WorksheetFunctions Funções de Planilhas que retornam valores do VBA