Fabiosp,

Bom Dia!

Veja se é assim.

Olá prezado colega Wagner Morel.

Muito obrigado pela costumeira atenção.

Era isso mesmo que necessitava.

Está perfeito porém só mais uma dúvida.

Será que a rotina em evento Worksheet_Change que criei esta correta?

As vezes quando apago o resultado da coluna C o número`1`da coluna D não desaparece.

Desde já agradeço a ajuda e compreensão.

Abraços.

Abaixo segue o código:

Private Sub Worksheet_Change(ByVal Target As Range)
        
        Dim sValor
        
        If Not Intersect(Target, [C2:C1001]) Is Nothing Then
            sValor = Target.Value
            
            If sValor = "" Then
                Target.Offset(0, 1).Value = "1"
            Else
                Target.Offset(0, 1).Value = "1"
            End If

        End If
        
    End Sub

Sub COPIANDO()
'Declaração de variáveis
Dim i As Long
Dim UltimaLinha As Long

Range("F6").Select
Call convertendo_text_para_num

Application.ScreenUpdating = False
Application.Calculation = xlManual

    Workbooks.Open Filename:= _
        ActiveWorkbook.Path & "RELATORIOFEV2014.xls"
    Range("A5:E5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("LISTA GERAL2014.xls").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("F6:J6").Select
    Range(Selection, Selection.End(xlDown)).Select
    
    Selection.Sort Key1:=Range("F6"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin, DataOption1:=xlSortNormal
    Range("F6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
   
    Range("A6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("F6").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range("F6").Select
    Workbooks("RELATORIOFEV2014.xls").Save
    Workbooks("RELATORIOFEV2014.xls").Close
    
    Call Comparar
    Call FILTRAR
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    'Inserindo a data do dia na coluna H
    UltimaLinha = Sheets("SAIDAS").Cells(Cells.Rows.Count, 1).End(xlUp).Row
    For i = 2 To UltimaLinha
        If Range("D" & i).Value = 1 Then Range("H" & i).Value = Date
    Next
    MsgBox "ACABOU"

End Sub


Sub Comparar()
Application.ScreenUpdating = False
Application.Calculation = xlManual

Dim Comparar As Variant
Dim x As Variant
Dim y As Variant

Set Comparar = Range("B1:B1000")

For Each x In Range("A1:A1000")
For Each y In Comparar
If x = y Then x.Offset(0, 2) = x
Next y
Next x
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Sub convertendo_text_para_num()

Application.ScreenUpdating = False
Application.Calculation = xlManual

For Each WS In Sheets
On Error Resume Next
For Each r In WS.UsedRange.SpecialCells(xlCellTypeConstants)
If IsNumeric(r) Then r.Value = Val(r.Value)
Next
Next

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic


End Sub


Sub FILTRAR()

Cells.Select
Selection.AutoFilter
 Range("D1").Select
 Selection.AutoFilter Field:=4, Criteria1:="1"

End Sub

Acho que o erro está nessas linhas (dentro do IF):
O que você está dizendo nesse IF é o seguinte:
1 - sValor armazena o que for digitado na célula ativa
2 - Se sValor não tiver nada (se não foi digitado nada na célula ativa), coloca na célula que fica na mesma linha, próxima coluna, o número 1.
3 - Caso contrário, ou seja, se sValor já tiver algo armazenado, também coloca na célula que fica na mesma linha, próxima coluna, o número 1.

É aí que não entendi... como pode atender a duas condições diferentes o mesmo número 1. No caso do Else, não seria, por exemplo, não fazer nada???

            sValor = Target.Value
           
            If sValor = "" Then
                Target.Offset(0, 1).Value = "1" 
            Else
                Target.Offset(0, 1).Value = "1"
            End If

Prezado colega Wagner Morel

Muito obrigado pela resposta espero algum dia retribuir sua generosidade.
Mas subistituindo o Else por fazer nada caso apague a informação da coluna C o número "1" não deveria sumir?
Seria necessário incluir um código?

Novamente agradeço sua ajuda caro colega.

Grande abraço.

Como eu disse, eu não entendi a lógica da sua programação...
Talvez seja isso:

Target.Offset(0, 1).Value = ""

Boa noite caro colega Wagner Morel

muito obrigado pela ajuda!!

foi muito útil para poder concluir minha tarefa.

Abraços.

Caso seja necessário reabrir o tópico, o autor poderá enviar uma MP para um dos moderadores solicitando o desbloqueio.