VBA code to only affect blank cells

[KGards7]

Hi all, I am currently using the following vba code which I have assigned to a button which basically performs a vlookup between two workbooks but for columns S, T & U in the "SAS MI Extraction - TEST" workbook I want it so that it only affects blank cells. At the moment if there is any existing information in columns S, T & U the below code overrides what is in there. I don't want that to happen and to leave any existing text in the columns alone:

"Sub PerformChecks()

Dim w1 As Worksheet, wAs Worksheet
Dim c As Range, FR As Variant

Application.ScreenUpdatin False

Set w1 = Workbooks("SAS MI Extraction - TEST").Worksheets("SAS MI Data")
Set w2 = Workbooks("OIMDataRefresh_DMZ").Worksheets("OIMDataefresh_DMZ")

For EachIn w1.Range("R2", w1.Range("R" & Rows.Count).End(xlUp))
FR = Application.Match(c, w2.Columns("A"), 0)
If IsNeric(FR) Then w1.Range("S" & c.Row).Value = w2.Range("F" & FR).Value
If IsNumeric(FR) Then w1.Range("T" & c.Row).Value = w2.Range("H" & FR).Value
If IsNumeric(FR) Then w1.Range("U" & c.Row).Value = w2.Range(J" & FR).Value
Next c

Application.ScreenUpdating = True

End Sub"

 

[Jimmypop]

Hi there

This is untested...

Sub PerformChecks()

    Dim w1 As Worksheet, w2 As Worksheet
    Dim c As Range, FR As Variant
    Dim checkRange As Range
    
    Application.ScreenUpdating = False

    Set w1 = Workbooks("SAS MI Extraction - TEST").Worksheets("SAS MI Data")
    Set w2 = Workbooks("OIMDataRefresh_DMZ").Worksheets("OIMDataefresh_DMZ")
    Set checkRange = w1.Range("R2", w1.Range("R" & Rows.Count).End(xlUp)) ' Combined range to check
    
    For Each c In checkRange

        ' Check if the cell in column S, T, U is blank
        ' and if there is a match in the lookup range
        If Len(w1.Range("S" & c.Row).Value) = 0 And Len(w1.Range("T" & c.Row).Value) = 0 And Len(w1.Range("U" & c.Row).Value) = 0 _
                And IsNumeric(Application.Match(c, w2.Columns("A"), 0)) Then
            FR = Application.Match(c, w2.Columns("A"), 0)
            w1.Range("S" & c.Row).Value = w2.Range("F" & FR).Value
            w1.Range("T" & c.Row).Value = w2.Range("H" & FR).Value
            w1.Range("U" & c.Row).Value = w2.Range("J" & FR).Value
        End If

    Next c

    Application.ScreenUpdating = True

End Sub

 

[ChrisFoster]

Try:

Sub PerformChecks()

    Dim w1 As Worksheet, w2 As Worksheet
    Dim c As Range, FR As Variant

    Application.ScreenUpdating = False

    Set w1 = Workbooks("SAS MI Extraction - TEST").Worksheets("SAS MI Data")
    Set w2 = Workbooks("OIMDataRefresh_DMZ").Worksheets("OIMDataefresh_DMZ")

    For Each c In w1.Range("R2", w1.Range("R" & Rows.Count).End(xlUp))
        FR = Application.Match(c, w2.Columns("A"), 0)
        If IsNumeric(FR) Then
            If w1.Range("S" & c.Row).Value = "" Then w1.Range("S" & c.Row).Value = w2.Range("F" & FR).Value
            If w1.Range("T" & c.Row).Value = "" Then w1.Range("T" & c.Row).Value = w2.Range("H" & FR).Value
            If w1.Range("U" & c.Row).Value = "" Then w1.Range("U" & c.Row).Value = w2.Range("J" & FR).Value
        End If
    Next c

    Application.ScreenUpdating = True

End Sub