CODEWITHSUNDEEP
vbaexcel
user3468115
user3468115

Reputation: 5

VBA to change cell value based on multiple criteria (number and dates)

I need VBA help to replace content of a certain column based on multiple criterion.

If the value in the Extension Column in Sheet1 is found in the Extension column in Sheet2 AND the Date in Sheet1 equals or falls between Date From and Date To in Sheet2, replace Number in Sheet1 with the corresponding Number in Sheet2, Else, do nothing.

Here's a screenshot of the details. http://prntscr.com/3tnf6t

And a link to a file with sample entries. http://1drv.ms/1skLYJR

I tried recording a macro doing auto filters but couldn't figure out a way to enter the corresponding number for records that meet all criteria.

Any help would be greatly appreciated.

Thanks!

Upvotes: 0

Views: 1874

Answers (1)

Haris
Haris

Reputation: 788

I had to make some small changes to your Excel to get it work. I replaced your Today's in Sheet2 with the Excel-Function TODAY() which simply returns the current date. Afterwards this quick and dirty solution should fix your issue. 

Sub checkAndReplace()

Dim currentRowS1, currentRowS2 As Integer

Range("B1:A" + CStr(ThisWorkbook.Worksheets("Sheet1").UsedRange.Count) + ",A1:A" + CStr(ThisWorkbook.Worksheets("Sheet2").UsedRange.Count)).Select

For currentRowS1 = 2 To ThisWorkbook.Worksheets("Sheet1").UsedRange.Count
    For currentRowS2 = 2 To ThisWorkbook.Worksheets("Sheet2").UsedRange.Count
    If ThisWorkbook.Worksheets("Sheet1").Range("B" & currentRowS1).Text = ThisWorkbook.Worksheets("Sheet2").Range("A" & currentRowS2).Text Then
        If DateDiff("d", ThisWorkbook.Worksheets("Sheet1").Range("A" & currentRowS1), ThisWorkbook.Worksheets("Sheet2").Range("B" & currentRowS2)) <= 0 And DateDiff("d",     ThisWorkbook.Worksheets("Sheet1").Range("A" & currentRowS1), ThisWorkbook.Worksheets("Sheet2").Range("C" & currentRowS2)) >= 0 Then
        ThisWorkbook.Worksheets("Sheet1").Range("C" & currentRowS1).Value = ThisWorkbook.Worksheets("Sheet2").Range("D" & currentRowS2).Value
        End If
    End If

    Next
Next

End Sub

Upvotes: 0

Related Questions