Rodar dois macros a...
 
Notifications
Clear all

Rodar dois macros ao mesmo tempo

8 Posts
3 Usuários
0 Likes
2,268 Visualizações
(@yukio-ota)
Posts: 8
Active Member
Topic starter
 

Bom dia a Todos !
Como já tive bons retornos dos colegas daqui, espero que possam me ajudar neste meu caso:
Agora tenho dois macros que em arquivos separados funcionam, mas quando coloquei no mesmo arquivo e pasta, só um deles roda e outro nada acontece.
Vocês podem me dar esta ajuda??
Aqui os VBAs que deveriam rodar na mesma planilha:

Sub Worksheet_change(ByVal target As Range)
'Declaracao das variaveis
Dim rw, valido, Celula As String, condicao
rw = target.Row

' tabela matriz com condicoes
valido = Application.WorksheetFunction.CountIf(Plan2.Range("A:A"), rw)

If valido = 0 Then Exit Sub

If Intersect(target, Range("A" & rw)) Is Nothing Then '
Exit Sub
End If

condicao = Application.WorksheetFunction.VLookup(rw, Plan2.Range("A:D"), 2, 0)

If target.Value <> condicao Then Exit Sub

'Celulas onde receberao as imagens
Celula = "A" & Application.WorksheetFunction.VLookup(rw, Plan2.Range("A:D"), 3, 0) & ":B" & Application.WorksheetFunction.VLookup(rw, Plan2.Range("A:D"), 4, 0)

' Definicao do tipo de arquivo-imagem
ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"

' Escolha do arquivo-imagem a ser inserido
Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = False Then End

' Redimensiona Imagem no local da celula
Set Imagem = ActiveSheet.Pictures.Insert(Pict)
Imagem.Top = Range(Celula).Top + 1.75
Imagem.Left = Range(Celula).Left + 1.75
Imagem.ShapeRange.LockAspectRatio = msoFalse
Imagem.Height = Range(Celula).Height * 1 - 3 '1 = Quantidade de linhas...
Imagem.Width = Range(Celula).Width * 1 - 3 '1 = Quantidade de colunas...

End Sub

Private Sub Worksheet_change(ByVal target As Range)
'Declarando variáveis
Dim x, y

'Inicio Intersect
If Not Intersect(target, Range("C:C")) Is Nothing Then

'Verifica se a linha na coluna C faz parte da range matriz onde ficarão os números
x = Application.WorksheetFunction.CountIf(Sheets("Apoio").Range("A:A"), target.Row)

'Se x for igual a 0, ou seja, não faz parte da range, encerra a macro
If x = 0 Then Exit Sub

'Caso ao contrario, continua nesta linha que verifica se o numero digitado existe na guia TAB
y = Application.WorksheetFunction.CountIf(Sheets("TAB").Range("A:A"), target.Value * 1)

'Se não existir ele encerra a macro
If y = 0 Then Exit Sub

'Realiza o procv
Range("D" & target.Row * 1).Value = Application.WorksheetFunction.VLookup(target.Value, Sheets("TAB").Range("A:D"), 2, 0)
Range("E" & target.Row * 1).Value = Application.WorksheetFunction.VLookup(target.Value, Sheets("TAB").Range("A:D"), 3, 0)
Range("F" & target.Row * 1).Value = Application.WorksheetFunction.VLookup(target.Value, Sheets("TAB").Range("A:D"), 4, 0)

End If
End Sub

 
Postado : 10/03/2014 7:05 am
(@gtsalikis)
Posts: 2373
Noble Member
 

Amigo, essa sub:

Sub Worksheet_change(ByVal target As Range)

É um evento da planilha, que acontece toda vez que alguma alteração é feita. Por isso, vc só pode ter uma única sub destas por planilha.

Eu, na verdade, não li o código todo, mas tente deixar assim:

Sub Worksheet_change(ByVal target As Range)
'Declaracao das variaveis
Dim rw, valido, Celula As String, condicao
rw = target.Row

' tabela matriz com condicoes
valido = Application.WorksheetFunction.CountIf(Plan2.Range("A:A"), rw)

If valido = 0 Then Exit Sub

If Intersect(target, Range("A" & rw)) Is Nothing Then '
Exit Sub
End If

condicao = Application.WorksheetFunction.VLookup(rw, Plan2.Range("A:D"), 2, 0)

If target.Value <> condicao Then Exit Sub

'Celulas onde receberao as imagens
Celula = "A" & Application.WorksheetFunction.VLookup(rw, Plan2.Range("A:D"), 3, 0) & ":B" & Application.WorksheetFunction.VLookup(rw, Plan2.Range("A:D"), 4, 0)

' Definicao do tipo de arquivo-imagem
ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"

' Escolha do arquivo-imagem a ser inserido
Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = False Then End

' Redimensiona Imagem no local da celula
Set Imagem = ActiveSheet.Pictures.Insert(Pict)
Imagem.Top = Range(Celula).Top + 1.75
Imagem.Left = Range(Celula).Left + 1.75
Imagem.ShapeRange.LockAspectRatio = msoFalse
Imagem.Height = Range(Celula).Height * 1 - 3 '1 = Quantidade de linhas...
Imagem.Width = Range(Celula).Width * 1 - 3 '1 = Quantidade de colunas...

'Declarando variáveis
Dim x, y

'Inicio Intersect
If Not Intersect(target, Range("C:C")) Is Nothing Then

'Verifica se a linha na coluna C faz parte da range matriz onde ficarão os números
x = Application.WorksheetFunction.CountIf(Sheets("Apoio").Range("A:A"), target.Row)

'Se x for igual a 0, ou seja, não faz parte da range, encerra a macro
If x = 0 Then Exit Sub

'Caso ao contrario, continua nesta linha que verifica se o numero digitado existe na guia TAB
y = Application.WorksheetFunction.CountIf(Sheets("TAB").Range("A:A"), target.Value * 1)

'Se não existir ele encerra a macro
If y = 0 Then Exit Sub

'Realiza o procv
Range("D" & target.Row * 1).Value = Application.WorksheetFunction.VLookup(target.Value, Sheets("TAB").Range("A:D"), 2, 0)
Range("E" & target.Row * 1).Value = Application.WorksheetFunction.VLookup(target.Value, Sheets("TAB").Range("A:D"), 3, 0)
Range("F" & target.Row * 1).Value = Application.WorksheetFunction.VLookup(target.Value, Sheets("TAB").Range("A:D"), 4, 0)

End If
End Sub

Lembre-se de AGRADECER aos que te ajudaram, e de marcar o tópico como [Resolvido]
Gente que cuida de gente.

Gilmar

 
Postado : 10/03/2014 7:22 am
(@yukio-ota)
Posts: 8
Active Member
Topic starter
 

Boa noite Gilmar!!
Pra esclarecer o que acontece: Tenho uma planilha onde insiro várias imagens redimensionadas (já sei que a imagem flutua na planilha!) e nesta mesma planilha, tenho um PROCV onde tenho uma TABELA na outra pasta e faço esta busca na mesma linhas ( da minagem ) pela coluna " C ". Eu já tinha inserido vários PROCV por linha direto na planilha, porém o arquivo ficou muito pesado! Por isso o VBA, mas já vi que não se pode rodar duas macros ao mesmo tempo, então, estou pedindo ajuda em como as duas macros rodarem na mesma planilha!
Agradeço a atenção!!
Yukio

PS. Já fiz isso e não deu certo, e só rodou o de inserir imagens!!

 
Postado : 10/03/2014 8:15 pm
(@yukio-ota)
Posts: 8
Active Member
Topic starter
 

Bom dia!!
Estou anexando a planilha pela qual tenho estes dois macros que só um roda e outro não! Mas que preciso dos dois rodem ao mesmo tempo!

 
Postado : 10/03/2014 8:28 pm
(@gtsalikis)
Posts: 2373
Noble Member
 

tente assim:

Sub Worksheet_change(ByVal target As Range)
'Declaracao das variaveis
Dim rw, valido, Celula As String, condicao
rw = target.Row

' tabela matriz com condicoes
valido = Application.WorksheetFunction.CountIf(Plan2.Range("A:A"), rw)

If valido = 0 Then GoTo PARTE2

If Intersect(target, Range("A" & rw)) Is Nothing Then GoTo PARTE2

condicao = Application.WorksheetFunction.VLookup(rw, Plan2.Range("A:D"), 2, 0)

If target.Value <> condicao Then GoTo PARTE2

'Celulas onde receberao as imagens
Celula = "A" & Application.WorksheetFunction.VLookup(rw, Plan2.Range("A:D"), 3, 0) & ":B" & Application.WorksheetFunction.VLookup(rw, Plan2.Range("A:D"), 4, 0)

' Definicao do tipo de arquivo-imagem
ImgFileFormat = "Image Files JPG (*.jpg),*.jpg, Image Files GIF (*.gif),*.gif, Image Files BMP (*.bmp),*.bmp"

' Escolha do arquivo-imagem a ser inserido
Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = False Then End

' Redimensiona Imagem no local da celula
Set Imagem = ActiveSheet.Pictures.Insert(Pict)
Imagem.Top = Range(Celula).Top + 1.75
Imagem.Left = Range(Celula).Left + 1.75
Imagem.ShapeRange.LockAspectRatio = msoFalse
Imagem.Height = Range(Celula).Height * 1 - 3 '1 = Quantidade de linhas...
Imagem.Width = Range(Celula).Width * 1 - 3 '1 = Quantidade de colunas...

PARTE2

'Declarando variáveis
Dim x, y

'Inicio Intersect
If Not Intersect(target, Range("C:C")) Is Nothing Then

'Verifica se a linha na coluna C faz parte da range matriz onde ficarão os números
x = Application.WorksheetFunction.CountIf(Sheets("Apoio").Range("A:A"), target.Row)

'Se x for igual a 0, ou seja, não faz parte da range, encerra a macro
If x = 0 Then Exit Sub

'Caso ao contrario, continua nesta linha que verifica se o numero digitado existe na guia TAB
y = Application.WorksheetFunction.CountIf(Sheets("TAB").Range("A:A"), target.Value * 1)

'Se não existir ele encerra a macro
If y = 0 Then Exit Sub

'Realiza o procv
Range("D" & target.Row * 1).Value = Application.WorksheetFunction.VLookup(target.Value, Sheets("TAB").Range("A:D"), 2, 0)
Range("E" & target.Row * 1).Value = Application.WorksheetFunction.VLookup(target.Value, Sheets("TAB").Range("A:D"), 3, 0)
Range("F" & target.Row * 1).Value = Application.WorksheetFunction.VLookup(target.Value, Sheets("TAB").Range("A:D"), 4, 0)

End If
End Sub

Lembre-se de AGRADECER aos que te ajudaram, e de marcar o tópico como [Resolvido]
Gente que cuida de gente.

Gilmar

 
Postado : 11/03/2014 2:41 am
(@yukio-ota)
Posts: 8
Active Member
Topic starter
 

Bom dia Gilmar
Conforme a sua modificação, não executou, deu erro de compilação, você pode fazer o teste no arquivo que anexei!
Por enquanto agradeço pela ajuda!

 
Postado : 11/03/2014 9:25 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43753
Illustrious Member
 

Altere na macro proposta pelo colega Gilmar (após o nome PARTE2 acrescente " : "; caso contrario dará: ("erro de compilação sub não definida")

....
Imagem.Width = Range(Celula).Width * 1 - 3 '1 = Quantidade de colunas...

PARTE2:
'Declarando variáveis
Dim x, y...

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 11/03/2014 10:20 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43753
Illustrious Member
 

A pedido do Sr. Ota, anexo arquivo final , com o "acerto" das macros.

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 20/03/2014 9:14 am