Macro to display message end of Code where Col D contains blanks

H

howard

Well-known Member
Joined
Jun 26, 2006
Messages
6,563
Office Version
  1. 2021
Platform
  1. Windows
I have Data In Col D. I have VBA Code that inserts formulas and after the Code has Run and there blank cells in Col D where there is data in Col C in same row , then message box to state "Missing Descriptions" eg missing descriptions in D2, D5 etc . Col D2 onwards has a formula


Code: 
=IFERROR(INDEX(Codes!$AC$2:$AC$15,MATCH(TRUE,ISNUMBER(SEARCH(Codes!$AB$2:$AB$15,E2)),0)),"")


When running the code, the only part not displaying isn the message box


It would be appreciated if someone could kindly amend my code

See link to my sample data below

www.dropbox.com

Fixed Asset Upload Template Ver 1.3.xlsm

Shared with Dropbox
www.dropbox.com www.dropbox.com


Code: 
 Sub Formula()

Formula_Description

CopyAssetType_Surname



With Sheets("Fassets")

Dim LR As Long

LR = .Cells(.Rows.Count, "A").End(xlUp).Row



If .Range("A2") = "" Then

Exit Sub

End If



.Range("B2:B" & LR).FormulaR1C1 = _

"=VLOOKUP(RC[-1],'C:\Fixed Asset Upload Templates\[fixed Asset Upload Template.xlsm]Table'!R2C1:R22C3,2,FALSE)"



.Range("J2:J" & LR).FormulaR1C1 = _

"=VLOOKUP(RC[-9],'C:\Fixed Asset Upload Templates\[Fixed Asset Upload Template.xlsm]Table'!R2C1:R23C3,3,FALSE)"



.Range("K2:K" & LR).FormulaR1C1 = "=RC[1]"



.Range("R2:R" & LR).FormulaR1C1 = "=Codes!RC[4]&""=100"""



' Check for blank cells in Col D where there is data in Col C in the same row

Dim i As Long

Dim missingDescriptions As Boolean

missingDescriptions = False



For i = 2 To LR

' Use Evaluate to get the result of the formula in column D

Dim cellDResult As Variant

cellDResult = Application.Evaluate(.Range("D" & i).Formula)



' Check if the result is an empty string and Col C is not blank

If cellDResult = "" And .Range("C" & i).Value <> "" Then

Debug.Print "Missing Descriptions in cell D" & i

missingDescriptions = True

End If

Next i



If missingDescriptions Then

MsgBox "Some Descriptions are missing. Please check the highlighted cells."

End If

End With

End Sub


Sub Formula_Description()

Dim LR As Long, LR1 As Long

Dim lastRow As Long





With Sheets("Codes")

lastRow = .Cells(.Rows.Count, "AB").End(xlUp).Row

End With



With Sheets("Fassets")

LR = .Cells(.Rows.Count, "E").End(xlUp).Row

.Range("D2:D" & LR).Formula2R1C1 = _

"=IFERROR(INDEX(Codes!R2C29:R" & lastRow & "C29,MATCH(TRUE,ISNUMBER(SEARCH(Codes!R2C28:R" & lastRow & "C28,RC[1])),0)),"""")"

LR1 = .Cells(.Rows.Count, "E").End(xlUp).Row

.Range("I2:I" & LR1).FormulaR1C1 = "=EOMONTH(NOW(),-2)+1"

End With



Clear_Errors

End Sub



Sub CopyAssetType_Surname()

Dim LR As Long

With Sheets("Fassets")

LR = .Cells(.Rows.Count, "E").End(xlUp).Row

.Range("A2:A" & LR).Value = "'Computer Equipment"

.Range("O2:O" & LR).Value = "Administration"

End With



End Sub
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Sort by date Sort by votes
The macro works fine, but in your data that is in your file none of it meets this condition:

VBA Code: 
If cellDResult = "" And .Range("C" & i).Value <> "" Then

If you had data in column C, something like this:
1702194492871.png

The message would be:
1702194608314.png

Try the following code:

VBA Code: 
Sub Formula()
    Formula_Description
    CopyAssetType_Surname

    With Sheets("Fassets")
        Dim LR As Long
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        If .Range("A2") = "" Then
            Exit Sub
        End If
        
        .Range("B2:B" & LR).FormulaR1C1 = _
            "=VLOOKUP(RC[-1],'C:\Fixed Asset Upload Templates\[fixed Asset Upload Template.xlsm]Table'!R2C1:R22C3,2,FALSE)"

        .Range("J2:J" & LR).FormulaR1C1 = _
            "=VLOOKUP(RC[-9],'C:\Fixed Asset Upload Templates\[Fixed Asset Upload Template.xlsm]Table'!R2C1:R23C3,3,FALSE)"

        .Range("K2:K" & LR).FormulaR1C1 = "=RC[1]"

        .Range("R2:R" & LR).FormulaR1C1 = "=Codes!RC[4]&""=100"""
        
        ' Check for blank cells in Col D where there is data in Col C in the same row
        Dim i As Long
        Dim missingDescriptions As Boolean
        Dim cellDResult As Variant
        Dim txt As String
        
        missingDescriptions = False
        
        For i = 2 To LR
            ' Use Evaluate to get the result of the formula in column D
            
            cellDResult = Application.Evaluate(.Range("D" & i).Formula)
            
            ' Check if the result is an empty string and Col C is not blank
            If cellDResult = "" And .Range("C" & i).Value <> "" Then
                'Debug.Print "Missing Descriptions in cell D" & i
                txt = txt & "D" & i & ", "
                missingDescriptions = True
                .Range("D" & i).Interior.Color = vbYellow
            End If
        Next i
        
        If missingDescriptions Then
            MsgBox "Some Descriptions are missing. Please check the highlighted cells:" & _
              vbCr & Left(txt, Len(txt) - 2)
        End If
    End With
End Sub

I await your comments.
 
Upvote 0
Thanks Dante

I amended this part of code

Code: 
  If cellDResult = "" And .Range("C" & i).Value <> "" Then 

to

  If cellDResult = "" And .Range("C" & i).Value <> "" Then
 
Upvote 0
howard said:
Thanks Dante
I amended this part of code
If cellDResult = "" And .Range("C" & i).Value <> "" Then
to
If cellDResult = "" And .Range("C" & i).Value <> "" Then
Click to expand...

Those 2 lines are the same.

But, does your message already work with what I put in post #2?
 
Upvote 0
Hi Dante

I tested you Code again and When Col D has no blank Data and there is data in Col B in the same row , message states missing Data in D2, D3 & D4


Code: 
 Sub Formula()
    Formula_Description
    CopyAssetType_Surname

    With Sheets("Fassets")
        Dim LR As Long
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
       
        If .Range("A2") = "" Then
            Exit Sub
        End If
       
        .Range("B2:B" & LR).FormulaR1C1 = _
            "=VLOOKUP(RC[-1],'C:\Fixed Asset Upload Templates\[fixed Asset Upload Template.xlsm]Table'!R2C1:R22C3,2,FALSE)"

        .Range("J2:J" & LR).FormulaR1C1 = _
            "=VLOOKUP(RC[-9],'C:\Fixed Asset Upload Templates\[Fixed Asset Upload Template.xlsm]Table'!R2C1:R23C3,3,FALSE)"

        .Range("K2:K" & LR).FormulaR1C1 = "=RC[1]"

        .Range("R2:R" & LR).FormulaR1C1 = "=Codes!RC[4]&""=100"""
       
        ' Check for blank cells in Col D where there is data in Col C in the same row
        Dim i As Long
        Dim missingDescriptions As Boolean
        Dim cellDResult As Variant
        Dim txt As String
       
        missingDescriptions = False
       
        For i = 2 To LR
            ' Use Evaluate to get the result of the formula in column D
           
            cellDResult = Application.Evaluate(.Range("D" & i).Formula)
           
            ' Check if the result is an empty string and Col C is not blank
            If cellDResult = "" And .Range("B" & i).Value <> "" Then
                'Debug.Print "Missing Descriptions in cell D" & i
                txt = txt & "D" & i & ", "
                missingDescriptions = True
                .Range("D" & i).Interior.Color = vbYellow
            End If
        Next i
       
        If missingDescriptions Then
            MsgBox "Some Descriptions are missing. Please check the highlighted cells:" & _
              vbCr & Left(txt, Len(txt) - 2)
        End If
    End With
End Sub

See link Below
www.dropbox.com

Fixed Asset Upload Template Ver 1.3.xlsm

Shared with Dropbox
www.dropbox.com www.dropbox.com


Kindly Test & amend
 
Upvote 0
Hi Dante

I managed to amend the code and this works

Code: 
 Sub Formula()
    Formula_Description
    CopyAssetType_Surname

    With Sheets("Fassets")
        Dim LR As Long
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        If .Range("A2") = "" Then
            Exit Sub
        End If
        
        .Range("B2:B" & LR).FormulaR1C1 = _
            "=VLOOKUP(RC[-1],'C:\Fixed Asset Upload Templates\[fixed Asset Upload Template.xlsm]Table'!R2C1:R22C3,2,FALSE)"

        .Range("J2:J" & LR).FormulaR1C1 = _
            "=VLOOKUP(RC[-9],'C:\Fixed Asset Upload Templates\[Fixed Asset Upload Template.xlsm]Table'!R2C1:R23C3,3,FALSE)"

        .Range("K2:K" & LR).FormulaR1C1 = "=RC[1]"

        .Range("R2:R" & LR).FormulaR1C1 = "=Codes!RC[4]&""=100"""
        
        ' Check for blank cells in Col D where there is data in Col B in the same row
        Dim i As Long
        Dim missingDescriptions As Boolean
        Dim txt As String
        
        missingDescriptions = False
        
        For i = 2 To LR
            ' Check if the result is an empty string and Col B is not blank
            If .Range("D" & i).Value = "" And .Range("B" & i).Value <> "" Then
                txt = txt & "D" & i & ", "
                missingDescriptions = True
                .Range("D" & i).Interior.Color = vbYellow
            End If
        Next i
        
        If missingDescriptions Then
            MsgBox "Some Descriptions are missing. Please check the highlighted cells:" & _
              vbCr & Left(txt, Len(txt) - 2)
        End If
    End With
End Sub
 
Upvote 0
howard said:
When Col D has no blank Data and there is data in Col B in the same row
Click to expand...
So now it's column B. Then try:

VBA Code: 
 Sub Formula()
    Formula_Description
    CopyAssetType_Surname

    With Sheets("Fassets")
        Dim LR As Long
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        If .Range("A2") = "" Then
            Exit Sub
        End If
        
        .Range("B2:B" & LR).FormulaR1C1 = _
            "=VLOOKUP(RC[-1],'C:\Fixed Asset Upload Templates\[fixed Asset Upload Template.xlsm]Table'!R2C1:R22C3,2,FALSE)"

        .Range("J2:J" & LR).FormulaR1C1 = _
            "=VLOOKUP(RC[-9],'C:\Fixed Asset Upload Templates\[Fixed Asset Upload Template.xlsm]Table'!R2C1:R23C3,3,FALSE)"

        .Range("K2:K" & LR).FormulaR1C1 = "=RC[1]"

        .Range("R2:R" & LR).FormulaR1C1 = "=Codes!RC[4]&""=100"""
        
        ' Check for blank cells in Col D where there is data in Col B in the same row
        Dim i As Long
        Dim missingDescriptions As Boolean
        Dim txt As String
        
        missingDescriptions = False
        
        For i = 2 To LR
            ' Check if the result is an empty string and Col B is not blank
            If .Range("D" & i).Value = "" And .Range("B" & i).Value <> "" Then
                txt = txt & "D" & i & ", "
                missingDescriptions = True
                .Range("D" & i).Interior.Color = vbYellow
            End If
        Next i
        
        If missingDescriptions Then
            MsgBox "Some Descriptions are missing. Please check the highlighted cells:" & _
              vbCr & Left(txt, Len(txt) - 2)
        End If
    End With
End Sub

Regards
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

H
  • Solved
Formula Issue when Converting to VBA
Replies
3
Views
337
MARK858
MARK858
S
  • Question
Error message when executing macro
Replies
3
Views
157
rlv01
R
I
  • Question
Current Code taking 10 Hours to run. Need Help to Optimize
Replies
5
Views
263
ItalianPlatinum
I
T
  • Solved
VBA Name New column & Use Column Header as Range
Replies
7
Views
530
Peter_SSs
Peter_SSs
B
  • Question
record changes to a worksheet - (2)
Replies
1
Views
120
Joe4
Joe4

Forum statistics

Threads
1,215,071
Messages
6,122,963
Members
449,094
Latest member
Anshu121

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top