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

Escola Saberexcel VBA Estudos - site de quem precisa aprender Macros MS Excel VBA

Esse macro do Aplicativo Microsoft Excel VBA(Visual Basic Application), insere uma determinada imagem em todas as folhas de planilha do livro ativo.
note: o endereço do path(diretorio) da arquivo (jpg) imagem esta no proprio macro, então, faça a correção do caminho do do diretorio>
Espero que o exemplo possa lhe ser útil. Fique com Deus, Expedito Marcondes - 01-01-2012 : 10:29:00
'- - - - - - - - - - - - - - - - - - -'
Sub sbx_insere_imagem_todas_folhas_planihas()
i = InputBox(prompt:="Entre com a célula [ex: b8] ", Title:="Escola Saberexcel VBA Estudos®")
'se caso cancelar a operação nao ocorrerá erro:
If i = cancel Then
Exit Sub
End If

On Error GoTo fim
For n = 1 To Sheets.Count
Sheets(n).Activate
Range(i).Select
ActiveSheet.Pictures.Insert ("C:\Programadores\saberExcel\vba\ATT00004.jpg")
Next n
exit sub
fim:
MsgBox ("ocorreu um erro verifique"), vbCritical, "Escola Saberexcel VBA Estudos®"
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.



 

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

Esse macro(codigo) do Aplicativo Microsoft Excel VBA(Visual Basic Application), insere um shapes(Imagem) em uma autoforma com tamanho determinado. Observe que a primeira retira a linha de borda do shapes.

Sub Inserir_Imagem()
Dim vImagem As String
Dim Sh As Shape
Set Sh = Worksheets("Inserir_Imagem").Shapes.AddShape(msoShapeRectangle, 30, 40, 120, 25)
vImagem = ThisWorkbook.Path & "\Logo.JPG"
Sh.Fill.UserPicture vImagem
End Sub

'Sem as bordas
'Essa macro retira a linha de borda da imagem.
Sub Inserir_imagem_sem_linha()
Dim strImage As String
Dim Sh As Shape
Set Sh = Worksheets("Inserir_Imagem").Shapes.AddShape(msoShapeRectangle, 30, 40, 120, 125)
strImage = ThisWorkbook.Path & "\paisagem.JPG"
Sh.Line.Visible = msoFalse 'retira a linha da borda.
Sh.Fill.UserPicture strImage
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

Esses macros do Aplicativo Microsoft Excel VBA(Visual Basic Application), movimenta uma imagem de acordo com a incrementação de uma instrução for next ( loop ) e decrementa retornando a mensagem, tornando uma mensagem derrolante. Espero que o exemplo possa lhe ser útil.
Fique com Deus, Expedito Marcondes.

Sub Loop_imagem()
On Error Resume Next
ActiveSheet.Shapes("sbx_macro").Visible = True
Set img = ActiveSheet.Shapes("SaberExcel")
For i = 36 To 527
img.Left = i
[E2].Value = i
DoEvents
Next i
For i = 527 To 36 Step -1
img.Left = i
[E2].Value = i
DoEvents
Next i
ActiveSheet.Shapes("sbx_macro").Visible = False
End Sub

Sub Loop_imagem_I()
Set img1 = ActiveSheet.Shapes("abc")
Set img = ActiveSheet.Shapes("Saberexcel")

For i = 36 To 527
img1.Left = i
img.Left = i
[E2].Value = i
DoEvents
Next i

For i = 527 To 36 Step -1
img.Left = i
img1.Left = i
[E2].Value = i
DoEvents
Next i
End Sub

'com esse macro voce poderá indicar a localização desejada de determinado shapes, podendo usar uma condição
'e mostrar um shapes, o exemplo abaixo voce movimenta a imagem a cada interação no objeto barra de rolagem
'exemplo na folha de planiha. Baixe-a no final da página.
Sub inserir_imagem_local()
Set vLocal = ActiveSheet.Shapes("burro")
vLocal.Top = Range("M18").Value '177.75
vLocal.Left = Range("M20").Value '8.75
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.

Escola Saberexcel VBA Estudos - Treinamento com Macros, Fórmulas e Funções

Esses macros do Aplicativo Microsoft Excel VBA(Visual Basic Application), ocultam ou mostram os shapes, observe que nesta coleção de Shapes(Autoformas) imagens usei um temporizador para pausar o giro da instrução Loop For ...Next.
Espero que gostem do Exemplo. fiquem com Deus, Expedito Marcondes

' - - - - - - - - - - - - - - - -'
Sub sbx_oculta_Shapes()
sbx_smile_20_f

For i = 1 To 20
On Error Resume Next
With ActiveSheet
.Shapes("saber" & i).Visible = False
End With
Next i

[A1].Select
End Sub
' - - - - - - - - - - - - - - - -'
Sub sbx_mostrar_shapes()
sbx_oculta_Shapes
For i = 1 To 20
On Error Resume Next

With ActiveSheet
.Shapes("saber" & i).Visible = True
End With
Tempo 0.5
Next i

sbx_oculta_Shapes
sbx_smile_20_t
[A1].Select
End Sub
' - - - - - - - - - - - - - - - -'

Sub Tempo(SbTempo)
Dim VelhoTempo As Variant
If SbTempo < 0.01 Or SbTempo > 300 Then SbTempo = 1

VelhoTempo = Timer
Do
DoEvents
Loop Until Timer - VelhoTempo >= SbTempo
End Sub
' - - - - - - - - - - - - - - - -'
Sub sbx_smile_20_t()
Saber1.Shapes("saberexcel").Visible = True
End Sub
' - - - - - - - - - - - - - - - -'
Sub sbx_smile_20_f()
Saber1.Shapes("saberexcel").Visible = False
End Sub
' - - - - - - - - - - - - - - - -'

'observe que aqui criamos um objeto wordPad para mostrar o macro na tela ou diretamente no VBE(Visual Basic Editor)
Sub sbx_visualizar_macro()
Dim Resposta As String
Resposta = MsgBox("deseja visualizar(tela ou vbe)?" & vbCrLf & " se SIM = Tela" & vbCrLf & " se NAO = VBE", vbYesNo, "Saberexcel - o site das macros")
If Resposta = 6 Then
ActiveSheet.Shapes.Range(Array("macro")).Select
Selection.Verb Verb:=xlPrimary
Else
Application.Goto reference:="sbx_oculta_Shapes"
End If
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.