Check Adjacent Cell (real time)

[brychu]

Hi All,
this is my first time here to write with you because mostly I found answers for my questions in the past, but this time I didn't find and need your help
I have two columns A and B. The are some values in column A (for example 5 rows).

COL A COL B
a
b
c
d
e

In column B I enter some values manually (measuring tool) row by row, one by one always.
I would like to have macro which checks me all the time (real time) during I enter values in column B from measuring tool row by row, when I reach a row in column B that cell in column A is empty.
Then I can call some action (message box or another macro).
So simply check when I reach end of the list in column A, entering values in column B, it should do some action.
Do you know how to handle it?
In case of any question pls write me.

Thx a lot for your support.

 

[Sequoyah]

Hi @brychu,
Here's a VBA macro that will display a message when you enter a value in column B if column A in the same row is empty. You need to save your workbook as Excel Macro-Enabled Workbook (*.xlsm). This code goes in the Worksheet module, so it will trigger whenever there's a change in the worksheet. Right-click on the sheet tab, choose View Code to open the VBA editor, paste the following code:

Private Sub Worksheet_Change(ByVal Target As Range)
'https://www.mrexcel.com/board/threads/check-adjacent-cell-real-time.1266501/post-6228028

    ' Check if the change is in column B
    If Not Intersect(Target, Me.Columns("B")) Is Nothing Then
        Dim cell As Range
        For Each cell In Target
            ' Check if the cell in column A of the same row is empty
            If IsEmpty(cell.Offset(0, -1).Value) Then
                MsgBox "Please enter a value in column A before adding a value in column B.", vbExclamation, "Input Required"
                ' Clear the entered value in column B
                Application.EnableEvents = False
                cell.ClearContents
                Application.EnableEvents = True
            End If
        Next cell
    End If
End Sub

 

[brychu]

Hi All,
thx a lot.
Perfect but
I think I didn't write enough details.
An action which I have to do at the end is to save sheet as PDF automatically (archive without any action of user) and I have a part of code for this.
So when user uses measuring tools to enter values in Column B, we do not expect that he will enter something in Column B where cell on the left in Column A is empty, so this code will not work.
But maybe there is another way to achieve it ...
My next idea is to compare both columns A and B and not empty cells, for example if ranges A1:A50 and B1:B50 have the same amount of not empty cells then do something (i my case save to PDF automatically). So in this scenario user will enter last measure, amount of not empty cells in both columns will be the same and this will trigger an action.
Can you help me with this?

Thx a lot.

 

[brychu]

Ok I quickly prepared something like this, but how to run it in real time (during editing a sheet)?
It works when I run it manually.
When I enter something it should checks automatically and if range A1:A10 has the same amount of not empty cells as range B1:B10, it should automatically show a message.
Thz a lot for your help.

Sub CountNonBlanksInSingleColumnRange()

Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range: Set rg = ws.Range("A1:A10")
Dim rg2 As Range: Set rg2 = ws.Range("B1:B10")

Dim nbCount As Long: nbCount = rg.Rows.Count - Application.CountBlank(rg)
Dim nbCount2 As Long: nbCount2 = rg2.Rows.Count - Application.CountBlank(rg2)

'MsgBox nbCount & " cells are not blank.", vbInformation
If nbCount = nbCount2 Then
' Run your macro here
MsgBox "PDF created"
End If
End Sub

 

[brychu]

OK found it finally
But I have next question, how to add via another macro this code below to every new created sheet in workbook?


Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:B10")) Is Nothing Then
Call CountNonBlanksInRange
End If
End Sub

Sub CountNonBlanksInRange()

Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg1 As Range: Set rg1 = ws.Range("A1:A10")
Dim rg2 As Range: Set rg2 = ws.Range("B1:B10")

Dim nbCount1 As Long: nbCount1 = rg1.Rows.Count - Application.CountBlank(rg1)
Dim nbCount2 As Long: nbCount2 = rg2.Rows.Count - Application.CountBlank(rg2)

If nbCount1 = nbCount2 Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="C:\temp\" & Format(Now, "yyyymmdd_hhmmss") & ".pdf"
MsgBox "PDF created"
End If
End Sub

 

[brychu]

Ok, got it

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Range("G2:H50")) Is Nothing Then
Call CountNonBlanksInRange
End If
End Sub

Sub CountNonBlanksInRange()

Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg1 As Range: Set rg1 = ws.Range("G2:G50")
Dim rg2 As Range: Set rg2 = ws.Range("H2:H50")

Dim nbCount1 As Long: nbCount1 = rg1.Rows.Count - Application.CountBlank(rg1)
Dim nbCount2 As Long: nbCount2 = rg2.Rows.Count - Application.CountBlank(rg2)

If nbCount1 = nbCount2 Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="C:\temp\" & Range("A2").Value & "_" & Format(Now, "yyyymmdd_hhmmss") & ".pdf"
MsgBox "PDF created"
End If
End Sub