none
Formatação Condicional, Inserir Comentários com VBA RRS feed

  • Pergunta

  • Olá,

    Tenho duas folhas de trabalho em excel 2010: Folha Lotes e Folha Mês

    O que eu pretendia, com VBA: era procurar o valor de uma determinada célula, (a célula pode variar), na folha Lotes, e devolveria em comentário: Falta Chegar – o valor da coluna Q da folha Lotes; Falta Aprovação – o valor da coluna R da folha Lotes.

    Adicionalmente, com VBA, o valor em questão seria formatado recorrendo a formatação condicional: se ambos os valores das células das colunas M e N, da folha Lotes fossem OK, o valor seria formatado a verde; se o da Coluna M fosse OK e o da N não, o valor seria formatao a castanho; se ambos estivessem vazios, o valor seria formatado a vermelho

    No Comentário, também deveria ser colocada a data da actualização, e o nome do usuário que fez a actualização.

    É possível?

    Obrigada

    quinta-feira, 28 de março de 2013 16:42

Respostas

  • "O que eu pretendia, com VBA: era procurar o valor de uma determinada célula, (a célula pode variar)"

    A célula pode variar de coluna também ou apenas de linha? Estou considerando que ela varia apenas de linha, mas sempre está na mesma coluna, o que ocorre normalmente. No caso, estou usando a coluna A como exemplo.

    Experimente adaptar o código abaixo. Fiz algumas premissas por você não ter detalhado onde as informações são coladas na planilha Mês:

    Sub fMain()
        Dim wksLotes As Worksheet
        Dim wksMês As Worksheet
        Dim lngLotes As Long
        Dim strBusca As String
        
        With ThisWorkbook
            Set wksLotes = .Worksheets("Lotes")
            Set wksMês = .Worksheets("Mês")
        End With
        
        strBusca = InputBox("Digite o valor a procurar")
        If strBusca = "" Then Exit Sub
        
        lngLotes = fMatch(strBusca, wksLotes.Columns("A"))
        
        If lngLotes > 0 Then
            wksMês.Range("A1") = "Falta Chegar " & wksLotes.Cells(lngLotes, "Q")
            wksMês.Range("A2") = "Falta Aprovação " & wksLotes.Cells(lngLotes, "R")
            wksMês.Range("A3") = Date 'Data de Atualização
            wksMês.Range("A4") = Application.UserName 'Nome do usuário que fez a atualização
            
            'Colorir
            If wksLotes.Cells(lngLotes, "M") = "OK" And wksLotes.Cells(lngLotes, "N") = "OK" Then
                wksMês.Range("A1,A2").Interior.Color = RGB(127, 192, 127) 'Verde
            ElseIf wksLotes.Cells(lngLotes, "M") = "OK" Then
                wksMês.Range("A1,A2").Interior.Color = RGB(192, 192, 127) 'Castanho
            Else
                wksMês.Range("A1,A2").Interior.Color = RGB(255, 192, 192) 'Vermelho
            End If
        Else
            wksMês.Range("A1") = "Informação não encontrada"
        End If
    
    End Sub
    
    Function fMatch(ByVal vTermo As Variant, ByVal vVetor As Variant) As Long
        'Se vVetor for um objeto Range, retorna o número da linha ou coluna
        'de uma célula com conteúdo vTermo numa linha ou coluna.
        'Se vVetor for um vetor, retorna o índice do elemento vTermo no vetor.
        'Caso não seja encontrada nenhuma ocorrência, é retornado 0.
        
        Dim Temp 'As Long
        
        On Error Resume Next
        Temp = WorksheetFunction.Match(CStr(vTermo), vVetor, 0)
        If Temp = 0 Then Temp = WorksheetFunction.Match(vTermo + 0, vVetor, 0)
        On Error GoTo 0
        
        If Temp > 0 Then
            Select Case TypeName(vVetor)
                Case "Range"
                    If vVetor.Columns.Count = 1 Then
                        'vVetor é uma coluna
                        Temp = Temp + vVetor.Row - 1
                    ElseIf vVetor.Rows.Count = 1 Then
                        'vVetor é uma linha
                        Temp = Temp + vVetor.Column - 1
                    End If
            End Select
        End If
        
        fMatch = Temp
    End Function
    
    Function fRowLast(rng As Range) As Long
        'Retorna o número da última linha povoada do intervalo rng
        Dim Temp
        
        With rng
            On Error Resume Next
            Temp = .Find(What:="*" _
            , After:=.Cells(1) _
            , SearchDirection:=xlPrevious _
            , SearchOrder:=xlByColumns _
            , LookIn:=xlFormulas).Row
            If Temp = 0 Then Temp = rng.Cells(1).Row
        End With
        
        fRowLast = Temp
    End Function


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sexta-feira, 29 de março de 2013 14:31
    Moderador