excel vba clear cell value with if contain specific cell value

jhonatan321 · Jul 14, 2021

Good evening everyone, I'm looking for some code in vba that can find specified dates in a line, if the date is not the same I need to delete the 3 columns, I want to leave only dates in the line that correspond to date1 and date 2 as in the example
before

later

jhonatan321 · Jul 16, 2021

jhonatan321 said:
your first code removed the different dates in the line and cleared two cells on the side, now I need this line to bring the two cells closest to the times specified in these dates

the date needs to be the same is the time needs to be the closest and I can bring the cell on the closest time side

Crystalyzer · Jul 16, 2021

The new request is much more complex. I am working on this but most likely will not have a solution before the weekend.

Crystalyzer · Jul 16, 2021

I was able to finish and validate some scenarios. My testing is not exhaustive so there may be scenarios I have not considered.

Here is the final code

VBA Code:

Option Explicit

Sub RemoveData()
    Dim i As Integer
    Dim j As Integer
    Dim D1 As Date
    Dim D2 As Date
    Dim T1 As Double
    Dim T2 As Double
    Dim Day1Col As Long
    Dim Day2Col As Long
    Dim EntDte1Col As Long
    Dim Time1Col As Long
    Dim Time2Col As Long
    Dim CloseTime1Col As Long
    Dim CloseTime2Col As Long
    Dim CloseVal1Col As Long
    Dim CloseVal2Col As Long
    Dim TimeDiff1 As Double
    Dim TimeDiff2 As Double
    Dim LR As Long
    Dim LC As Long
    Dim rng As Range
    Dim ans As VbMsgBoxResult
    
Retry:
    On Error Resume Next
    Set rng = Nothing
    Set rng = Application.InputBox( _
        Title:="Range Selection", _
        Prompt:="Select the range that contains the data to evaluate INCLUDING column headers", _
        Type:=8)
    On Error GoTo 0
    
    If rng Is Nothing Then Exit Sub
    
    LR = rng.Row + rng.Rows.Count - 1
    LC = rng.Columns.Count
    TimeDiff1 = 999999
    TimeDiff2 = 999999
    
    
    On Error Resume Next
    Day1Col = WorksheetFunction.Match("Day 1", Range(Cells(rng.Row, rng.Column), Cells(rng.Row, LC)), 0)
    Day2Col = WorksheetFunction.Match("Day 2", Range(Cells(rng.Row, rng.Column), Cells(rng.Row, LC)), 0)
    Time1Col = WorksheetFunction.Match("Hora 1", Range(Cells(rng.Row, rng.Column), Cells(rng.Row, LC)), 0)
    Time2Col = WorksheetFunction.Match("Hora 2", Range(Cells(rng.Row, rng.Column), Cells(rng.Row, LC)), 0)
    CloseTime1Col = WorksheetFunction.Match("Close Time 1", Range(Cells(rng.Row, rng.Column), Cells(rng.Row, LC)), 0)
    CloseTime2Col = WorksheetFunction.Match("Close Time 2", Range(Cells(rng.Row, rng.Column), Cells(rng.Row, LC)), 0)
    CloseVal1Col = WorksheetFunction.Match("Close Value 1", Range(Cells(rng.Row, rng.Column), Cells(rng.Row, LC)), 0)
    CloseVal2Col = WorksheetFunction.Match("Close Value 2", Range(Cells(rng.Row, rng.Column), Cells(rng.Row, LC)), 0)
    EntDte1Col = WorksheetFunction.Match("Entry Date", Range(Cells(rng.Row, rng.Column), Cells(rng.Row, LC)), 0)
    On Error GoTo 0
    
    If Day1Col = 0 Or Day2Col = 0 Or Time1Col = 0 Or Time2Col = 0 Or CloseTime1Col = 0 Or CloseTime2Col = 0 Or CloseVal1Col = 0 Or CloseVal2Col = 0 Then
        ans = MsgBox("One or more of the following columns are missing from selection " & vbCrLf & vbCrLf _
            & "Day 1, Day 2, Hora 1, Hora 2." & vbCrLf _
            & "Close Time 1, Close Time 2" & vbCrLf _
            & "Close Value 1, Close Value 2", vbRetryCancel, "Range Selection Error!")
        If ans = vbRetry Then
            GoTo Retry
        Else
            Exit Sub
        End If
    End If
    
    If EntDte1Col = 0 Or LC - EntDte1Col < 2 Then
        ans = MsgBox("Either you did not select a column called Entry Date or you did not select enough columns to process." & vbCrLf & vbCrLf _
            & "You must select an Entry Date column with at least two columns to the right of that column to process the data.", vbRetryCancel, "Range Selection Error!")
        If ans = vbRetry Then
            GoTo Retry
        Else
            Exit Sub
        End If
    End If
        
   For i = rng.Row + 1 To LR
        D1 = Cells(i, Day1Col).Value
        D2 = Cells(i, Day2Col).Value
        T1 = Cells(i, Time1Col).Value
        T2 = Cells(i, Time2Col).Value
        TimeDiff1 = 999999
        TimeDiff2 = 999999
        
        For j = EntDte1Col To LC - 2 Step 3
            'Check if neither date matches and delete the data if they do not
            If Cells(i, j).Value <> D1 Then
                If Cells(i, j).Value <> D2 Then
                    Range(Cells(i, j), Cells(i, j + 2)).ClearContents
                    GoTo NxtCol
                End If
            End If
            
            'check if date matches D1
            If Cells(i, j).Value = D1 Then
                If TimeDiff1 <> 0 Then
                    If TimeDiff1 <> (T1 - Cells(i, j + 1).Value) Then
                        If TimeDiff1 > (T1 - Cells(i, j + 1).Value) And (T1 - Cells(i, j + 1).Value) >= 0 Then
                            TimeDiff1 = (T1 - Cells(i, j + 1).Value)
                            Cells(i, CloseTime1Col) = Cells(i, j + 1).Value
                            Cells(i, CloseVal1Col) = Cells(i, j + 2).Value
                        End If
                    End If
                End If
            End If
            
            'check if date matches D2
            If Cells(i, j).Value = D2 Then
                If TimeDiff2 <> 0 Then
                    If TimeDiff2 <> (T2 - Cells(i, j + 1).Value) Then
                        If TimeDiff2 > (T2 - Cells(i, j + 1).Value) And ((T2 - Cells(i, j + 1).Value)) >= 0 Then
                            TimeDiff2 = (T2 - Cells(i, j + 1).Value)
                            Cells(i, CloseTime2Col) = Cells(i, j + 1).Value
                            Cells(i, CloseVal2Col) = Cells(i, j + 2).Value
                        End If
                    End If
                End If
            End If
NxtCol:
        Next j
    Next i
                
End Sub

My Test Data, Expected Results, and Validation Tables

Solutions 20210713.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

1

Test Scenarios & Data

2

Person

Day 1

Hora 1

Close time 1

Close Value 1

Day 2

Hora 2

Close Time 2

Close Value 2

Entry Date

Hora

Old bin id

Entry Date

Hora

Old bin id

Entry Date

Hora

Old bin id

Entry Date

Hora

Old bin id

Entry Date

Hora

Old bin id

Entry Date

Hora

Old bin id

3

Match D1 time < T1 No D2 match

1/1/2021