Wendell Menezes

Oi amigo, não consigo, ficarei 3 semanas konge do meu PC . Clique com o botão direito no nome da sheet e depois em Exibir Codigo. Apague tudo o que tiver e coloque apenas o meu codigo e teste.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim Cell As Range
    Dim r    As Integer
    
    If Target.Address(False, False) = "B3" Then
        Range("A8:B506").ClearContents
            Else
        For Each Cell In Target
            If Cell.Row >= 8 And Cell.Column <= 2 Then
                With Sheets("Registo de horas")
                    For r = 8 To .Range("AS6")
                        If .Range("AT" & r) = "Pago" Then
                            .Range("Q" & .Range("AS" & r)) = "Pago"
                            .Range("R" & .Range("AS" & r)) = .Range("AU" & r)
                        End If
                    Next
                End With
            End If
        Next
    End If
End Sub

Cole o código acima no módulo da sheet "Consulta a um Piloto"

As colunas "AV" e "AW" da sheet "Registo de horas" não são necessárias.

=SE(ÉERROS(PROCV(A2;C:C;1;0));"Não";"Sim")

Boa tarde,

Segue planilha com exemplo, seria isso?

Meu Excel está em inglês, então talvez seja necessário alterar o formato da data para mmmm/aaa no seu computador.

Book1.xlsx

Oi Angelo,

Só para confirmar, você entende que o meu código é uma SUB comum que você deve adicionar à algum botão ou pressionar F5 com curso dentro do código para executar ele e ver o resultado?

Fiquei com essa dúvida porque o seu exemplo abaixo é uma SUB vinculada ao evento de alteração da planilha. Ou seja, o VBA ativa a macro automaticamente quando você altera o valor de qualquer célula.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B3")) Is Nothing Then
        Range("A7:A506").ClearContents
        Range("B7:B506").ClearContents
    End If
End Sub

Você quer que o LOOP seja feito quando? Quando você ativá-lo manualmente (como eu pensei que era) ou quando você alterar alguma célula / coluna em particular (de forma automática)?

O excel parece não aceitar essa combinação, mas você pode fazer isso de forma indireta.

=UNICO(Y) na célula A1

Depois em B1, =ORDEM.EQ(X;A1#;0)

Oi Angelo,

Na minha versão o loop encontra "Pago" na célula AT9 e escreve "Pago" na célula Q1175.

A sua versão encontra o mesmo "Pago" na célula AT9 e escreve "Pago" na célula AV9.

Qual é o correto?

Não sei se entendi bem, veja se seria algo assim;

Sub LOOP_ANGELO()

    Dim r As Integer
    
    With Sheets("Registo de horas")
        For r = 8 To .Range("AS6")
            If .Range("AT" & r) = "Pago" Then
                .Range("Q" & .Range("AS" & r)) = "Pago"
                .Range("R" & .Range("AS" & r)) = .Range("AU" & r)
            End If
        Next
    End With

End Sub

Experimente essa versão:

Private Sub Worksheet_Change(ByVal Target As Range) 'Por Wendell

    Dim Cell As Range
    
    For Each Cell In Target
        With Cell
            If .Column = 12 Then 'Coluna "L"
                Range("AY" & .Row).NumberFormat = "@" 'AY é Coluna VBA
                Range("AY" & .Row) = Range("AX" & .Row) 'AX é Coluna Fórmulas
            End If
        End With
    Next
    
End Sub

Clique com o botão direito no nome da aba -> Exibir Código e cole:

Private Sub Worksheet_Calculate()

On Error Resume Next
Range(Range("AW25")) = "Ocupado"


End Sub

A macro será ativada toda vez que o Excel cálcular o resultado das fórmulas e irá colocar "Ocupado" no endereço da célula que estiver escrita em AW25.

Bom dia,

Veja se seria isso:

Gastos mes ajuda.zip

Presumindo que a linha com o SUBTOTAL não exista e tenha que ser criada:

Sub SUBTOTAL()

Dim r   As Long
Dim h   As Byte

r = 14

While Cells(r, 1) <> ""
    h = 1
        While Cells(r, 4) = Cells(r + h, 4)
            h = h + 1
        Wend
    Cells(r + h, 4).EntireRow.Insert
    Cells(r + h, 2) = "**SUBTOTAL"
    Cells(r + h, 9).Formula = "=SUBTOTAL(9,I" & r & ":I" & r + h - 1 & ")"
    If IsNumeric(Cells(r, 11).End(xlUp)) Then
        Cells(r + h, 11).Formula = "=K" & Cells(r + 1, 11).End(xlUp).Row & "-I" & r + h
            Else
        Cells(r + h, 11).Formula = "=I" & r + 1
    End If
    r = r + h + 1
Wend

End Sub

Isso seria mais parecido com o que estava tentar fazer:

Sub EnterCell()

Dim Cell As Range

For Each Cell In Plan1.Range("FO1:FZ5000")
    Cell.Select
    Cell.Value = Cell.Value
Next

End Sub

Assim?

Sub COLAR_VALORES()

Plan1.Range("FO5:FZ5000").Value = Plan1.Range("FO5:FZ5000").Value

End Sub

Boa tarde,

Não sei se entendi bem, A LR verifica qual é a últinha linha da planilha para então testar em cada uma delas se atende a condição necessária para converter para negativo. Se retornasse um número menor (ex: apenas a quantidade de linhas com "Cod2" ela não iria terminar de converter até o final e o código iria parar antes da hora.

Seria isso?

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim Cell As Range
    
    For Each Cell In Target
        With Cell
            If .Column >= 171 And .Column <= 182 Then 'FO - FZ
                Range("GB" & .Row).NumberFormat = "@"
                Range("GB" & .Row) = Range("GA" & .Row)
            End If
        End With
    Next
    
End Sub

@Zamboni_du

Sub NEGATIVE()

Dim RefDate As Long
Dim LR      As Long
Dim r       As Long

RefDate = Range("J2")
LR = Cells(Rows.Count, 1).End(xlUp).Row

For r = 2 To LR
    If Cells(r, "A") = RefDate And Cells(r, "B") = "Cod2" Then
        If Cells(r, "C") > 0 Then Cells(r, "C") = Cells(r, "C") * -1
        If Cells(r, "D") > 0 Then Cells(r, "D") = Cells(r, "D") * -1
        If Cells(r, "E") > 0 Then Cells(r, "E") = Cells(r, "E") * -1
    End If
Next

End Sub

Boa tarde,

Dê uma olhada no tópico abaixo, não conheço um jeito "limpo" de fazer algo assim. Utilzei tabela dinâmica para lidar com as duplicatas e saber o tamanho (quantidade de itens) de cada lista para então usar DESLOC na validação de dados.

https://www.clubedohardware.com.br/forums/topic/1640183-validação-de-dados-dois-critério/

Boa tarde,

E como você quer que isso seja feito? Fórmula? VBA? Pode postar uma planilha com dados de modelo e os resultados esperados?

Independente de ser ComboBox ou ListView, é possível adicionar novos items a partir de células que são resultados de fórmulas, por isso acredito que o problema seja o código que você está utilizando para inserir novos items. Veja um exemplo que funciona mesmo com fórmulas nas células A1 e A2:

Eu confesso que não entendi porque o Dropdown não está sendo carregado pelo fato do ano ser resultado de uma fórmula. Qual é o código que você está usando para carregar ele?

Veja esse exemplo, A1 é uma fórmula:

O código que carrega ele é:

Private Sub ComboBox1_DropButtonClick()

ComboBox1.Clear
ComboBox1.AddItem Range("A2").Value

End Sub

Clique com o botão direito do mouse no nome da aba (ex: Plan1), depois exibir código. Cole o script abaixo e feche a janela.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim Cell As Range
    
    For Each Cell In Target
        With Cell
            If .Column = 183 Then 'Número da coluna GA
                Range("GB" & .Row).NumberFormat = "@"
                Range("GB" & .Row) = Range("GA" & .Row)
            End If
        End With
    Next
    
End Sub

Toda vez que alterar alguma coisa na coluna GA (ex: arrastando / inserindo fórmulas) o valor dela será colado como texto na coluna GB.

Agora se quiser que isso funcione APENAS na célula GA5:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Address(False, False) = "GA5" Then
        [GB5].NumberFormat = "@": [GB5] = [GA5]
    End If

End Sub

entendi, como última alternativa eu tentaria ativar a referência do Outlook e alterar o código para:

Dim OutApp as Outlook.Application
Set OutApp = New Outlook.Application

Boa tarde,

Não consigo testar o código porque não tenho Outlook nesse PC, mas experimente trocar a linha 12 por

Set OutApp = GetObject(, "Outlook.Application")

Bom dia,

Ficaria assim (alterar o valor da variável folder para a pasta onde estão os arquivos Excel a serem lidos):

Sub GET_SHEET_NAMES()

Dim FSO     As Object
Dim Folder  As String
Dim File    As Object
Dim wb      As Workbook
Dim ws      As Worksheet
Dim LR      As Long

Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
Folder = "C:\Users\PC\Desktop"

Application.DisplayAlerts = False

For Each File In FSO.GetFolder(Folder).Files
    If InStr(1, LCase(File), ".xls") > 0 And InStr(1, LCase(File), "$") = 0 And File.Name <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(File, UpdateLinks:=False)
        With ThisWorkbook.ActiveSheet
            LR = .Cells(Rows.Count, 1).End(xlUp).Row + 1
            For Each ws In wb.Worksheets
                .Cells(LR, 1) = wb.Name
                .Cells(LR, .Cells(LR, Columns.Count).End(xlToLeft).Column + 1) = ws.Name
            Next
        End With
        wb.Close False
    End If
Next

End Sub