ATENÇÃO NOVOS USUÁRIOS

Se registrou recentemente? Seu cadastro será avaliado e mendiante aprovação, a conta será ativada e você poderá usufruir do fórum. O tempo de avaliação gira em torno de 24 a 48 horas.

Esqueceu sua senha?

Você pode usar o mecanismo de lembrete neste link: Recuperar senha

Você receberá um link de reativação no email cadastrado.

Não recebeu o email? Lembre-se checar o Lixo Eletrônico.

APLICAR MACRO EM SELEÇÃO DE LISTBOX QUE ESTÃO EM PLANILHAS DIFERENTES.

Esclarecimentos e dúvidas sob o Modelo de Aplicativo de Cadastro em VBA no Microsoft Excel publicado no site e blog http://www.tomasvasquez.com.br
M@theu5
Acabou de chegar
Acabou de chegar
Mensagens: 2
Registrado em: Qua Ago 12, 2020 11:20 am

APLICAR MACRO EM SELEÇÃO DE LISTBOX QUE ESTÃO EM PLANILHAS DIFERENTES.

Mensagem por M@theu5 » Qua Ago 12, 2020 2:34 pm

Boa tarde!

Pessoal, tem possibilidade de uma macro ser executada em itens selecionados de uma listbox?

Já tenho quase tudo montado mas não sei como aplicar a macro sem ser na planilha ativa...

A primeira listbox me da a opção de surfar entre as planilhas para que eu posso verificar se realmente quero altera-lá, a segunda listbox foi criada com o intuito de marcar seleções diferentes para a macro de alteração só rodar nessa seleção, mas é aqui que eu me perco... Como fazer isso...

Código: Selecionar todos

Private Sub CommandButton1_Click()


On Error GoTo Erro
    Cells.Find(What:="108478", After:=ActiveCell, LookIn:=xlFormulas2, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.FormulaR1C1 = "503281"
    'LOCALIZA O COMPONENTE A SER ALTERADO E EXECUTA A ALTERAÇÃO
    Range("G3").Select
    ActiveCell.FormulaR1C1 = "08/05/2020"
    'MUDA A DATA (MÊS/DIA/ANO)
    Range("D3").Select
    Exit Sub
Erro:
msg = MsgBox("O Seguinte erro ocorreu: " & Err.Description)

End Sub


Private Sub CommandButton4_Click()
    Dim currentFind     As Excel.Range
    Dim firstFind       As Excel.Range
    Dim lQtdePlan       As Integer
    Dim lPlanAtual      As Integer
    Dim lPlanFim        As Boolean

    lQtdePlan = Worksheets.Count
    lPlanAtual = 1
    lPlanFim = False
    
    listResultado.Clear

    While lPlanAtual <= lQtdePlan
    
        Set currentFind = Worksheets(lPlanAtual).Range("A1:Z30").Find(txtPesquisa.Text, , _
            Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, _
            Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
        
        Set firstFind = Nothing
        
        While Not currentFind Is Nothing And lPlanFim = False
            If firstFind Is Nothing Then
                Set firstFind = currentFind
            ElseIf currentFind.Address = firstFind.Address Then
                lPlanFim = True
            End If
            If lPlanFim = False Then
                Set currentFind = Worksheets(lPlanAtual).Range("A1:Z30").FindNext(currentFind)
                listResultado.AddItem (Worksheets(lPlanAtual).Name & "!" & currentFind.Address)
            End If
            If lPlanFim = False Then
                Set currentFind = Worksheets(lPlanAtual).Range("A1:Z30").FindNext(currentFind)
                ListBox1.AddItem (Worksheets(lPlanAtual).Name & "!" & currentFind.Address)
            End If
        Wend
        lPlanAtual = lPlanAtual + 1
        lPlanFim = False
    Wend
    
Sair:
    Exit Sub
End Sub

Private Sub CommandButton5_Click()
 '''
    'Remover item
    '''
    'Remove item selecionado da lista 1
    Dim i As Long, contador As Long
    Dim vetor() As Variant
    With Me
        For i = .ListBox1.ListCount - 1 To 0 Step -1
            If .ListBox1.Selected(i) Then
                ReDim Preserve vetor(contador)
                msg = msg & vbCrLf & .ListBox1.List(i)
                vetor(contador) = i
                contador = contador + 1
            End If
        Next i
        resposta = MsgBox("Deseja alterar o item a seguir? " & msg, vbYesNo + vbQuestion, "Alterar?")
        If vbYes Then
            Alteraitem
        End If
    End With
End Sub
Sub Alteraitem()
 '''
    'Alterar item
    '''
    'Se houver um item selecionado no ListBox
    'e o mesmo tiver o indice diferente de -1 (sem item selecionado)
    If ListBox1.ListIndex <> -1 Then
        'Perguntamos se devemos prosseguir com a remoção do item selecioando
        If MsgBox("Deseja alterar o item selecionado?", vbQuestion + vbYesNo, "Alterar item?") = vbYes Then
            'Deletamos a linha seleciona inteira
            On Error GoTo Erro
            'Se ocorrer algum erro irá chamar o tratamento Erro
        Cells.Find(What:="108478", After:=ActiveCell, LookIn:=xlFormulas2, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.FormulaR1C1 = "503281"
            'LOCALIZA O COMPONENTE A SER ALTERADO E EXECUTA A ALTERAÇÃO
        Range("G3").Select
        ActiveCell.FormulaR1C1 = "08/05/2020"
            'MUDA A DATA (MÊS/DIA/ANO)
            MsgBox "Item alterado com sucesso!", vbInformation, "Alterado"
            'Definimos o indice do ListBox nenhum (-1)
            ListBox1.ListIndex = -1
        End If
    Else
        'Se não houver item selecionado,
        'Notificamos o usuário
        MsgBox "Nenhum item selecionado na lista!", vbExclamation, "Erro"
    End If
    Exit Sub
Erro:
    'Tratamento de erro GoTo
    msg = MsgBox("O Seguinte erro ocorreu: " & Err.Description)
End Sub
Private Sub ListBox1_Click()
 
End Sub

Private Sub listResultado_Click()

    Dim lRng        As Range
    Dim lEndereco()   As String
    lEndereco = Split(listResultado, "!")
    Worksheets(lEndereco(0)).Activate
    Set lRng = Range(lEndereco(1))
    lRng.Activate

End Sub



Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder