Fill a cell once the file is printed

[Lux Aeterna]

There's an excel form that we fill out and print several times every day. What I need is to have a cell filled every time the sheet is printed.

By the way, we only print as PDF using a macro and an assigned button.

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="C:\Users\pc50\Desktop\Νέα Τεστ Παπ\" & Range("AH1").Value _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True

So, if for example I put ID number 1 (ID number goes to $U$2 - Sheet Test results), I'd like cell B5 (Sheet Demographics) to get filled with the info from $AA$9 (Sheet Test results) as soon as the PDF is printed.
If I put ID number 2, I'd like cell B6 to get the info from $AA$9 and so on. List goes down to cell B10033 (Sheet Demographics).

It would be a great help if the PDF is allowed to be printed only when $AA$9 is filled.

Thank you in advance!

 

[mumps]

The unnecessary warning is when the respective cell in Demographics_column B is empty (it has to be empty when a supervisor fills out the Results form).

If column B in Demographics is empty but the corresponding cell in column A contains the ID from U2 in the Results sheet, do you want the macro to enter the supervisor's name from AA9 in the Results sheet in column B of Demographics?

 

[Lux Aeterna]

Demographics column A always contains an ID number beforehand. If supervisors enter an ID number in Results U2 that is not in the Demographics column A, it won't fetch any results and they won't be able to continue what they have to do.

So it's the other way round; Column A contains an ID and the corresponding cell in column B is empty. That's when I want the macro to copy the supervisor's name from AA9 to the corresponding cell in Column B.

• If the corresponding cell is not empty, I need to get a Yes-No warning (I'd rather have No as a default, if possible)
  • No selects and clears U2 cell.
  • Yes copies the supervisor's name.

By the way, if the ID they enter is U2 is not included in Demographics, it would be great if they were prompted to recheck the ID they entered, provided it won't make the macro too slow to run.

 

[mumps]

Try:

Sub PrintPDF()
    Application.ScreenUpdating = False
    Dim ID As Range, sup As String, sID As String
    If Sheets("Results").Range("AA9") = "" Then
        MsgBox ("Please enter a supervisor name in cell AA9.")
        Sheets("Results").Range("AA9").Select
        Exit Sub
    End If
    If Sheets("Results").Range("U2") = "" Then
        MsgBox ("Please enter an ID in cell U2.")
        Sheets("Results").Range("U2").Select
        Exit Sub
    End If
    Set ID = Sheets("Demographics").Range("A:A").Find(Sheets("Results").Range("U2").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not ID Is Nothing Then
        If ID.Offset(, 1) <> "" Then
            If MsgBox("This sample has already been tested by " & ID.Offset(, 1) & "." & Chr(10) _
                & "Are you sure you want to overwrite it?", vbYesNo + vbDefaultButton2) = vbYes Then
                ID.Offset(, 1) = Sheets("Results").Range("AA9")
            Else
                Sheets("Results").Range("U2").ClearContents
            End If
        Else
            ID.Offset(, 1) = Sheets("Results").Range("AA9")
        End If
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="C:\Users\pc50\Desktop\??a ?est ?ap\" & Range("AH1").Value _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Else
        MsgBox ("The ID " & Sheets("Results").Range("U2") & " does not exist." & Chr(10) & "Please enter a valid ID in cell U2.")
        With Range("U2")
            .ClearContents
            .Select
        End With
    End If
    Application.ScreenUpdating = True
End Sub

 

[Lux Aeterna]

Try:

Sub PrintPDF()
    Application.ScreenUpdating = False
    Dim ID As Range, sup As String, sID As String
    If Sheets("Results").Range("AA9") = "" Then
        MsgBox ("Please enter a supervisor name in cell AA9.")
        Sheets("Results").Range("AA9").Select
        Exit Sub
    End If
    If Sheets("Results").Range("U2") = "" Then
        MsgBox ("Please enter an ID in cell U2.")
        Sheets("Results").Range("U2").Select
        Exit Sub
    End If
    Set ID = Sheets("Demographics").Range("A:A").Find(Sheets("Results").Range("U2").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not ID Is Nothing Then
        If ID.Offset(, 1) <> "" Then
            If MsgBox("This sample has already been tested by " & ID.Offset(, 1) & "." & Chr(10) _
                & "Are you sure you want to overwrite it?", vbYesNo + vbDefaultButton2) = vbYes Then
                ID.Offset(, 1) = Sheets("Results").Range("AA9")
            Else
                Sheets("Results").Range("U2").ClearContents
            End If
        Else
            ID.Offset(, 1) = Sheets("Results").Range("AA9")
        End If
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="C:\Users\pc50\Desktop\??a ?est ?ap\" & Range("AH1").Value _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Else
        MsgBox ("The ID " & Sheets("Results").Range("U2") & " does not exist." & Chr(10) & "Please enter a valid ID in cell U2.")
        With Range("U2")
            .ClearContents
            .Select
        End With
    End If
    Application.ScreenUpdating = True
End Sub

Thanks a lot! I'll try it on Wednesday when I get back to work!

 

[Lux Aeterna]

@mumps, still getting errors due to the merged cell. I get a Runtime error 1004 in both cases. Skip the quoted part if not interested, because I managed to find a workaround, by copying and pasting parts of your code.

If I click No to replacement it's this



I tried to replace ClearContents with Select, but then the macro continues and prints the PDF, which is something I don't want to happen. If ClearContents is not possible, then Select and Exit sub would be my best alternative.

When I enter an ID which is not on the Demographics list, I get this

This is the workaround. Would you mind checking it for possible mistakes that could create problems?

Sub Αποθήκευση()
    Application.ScreenUpdating = False
    Dim ID As Range, sup As String, sID As String
    If Sheets("Results").Range("U2") = "" Then
        MsgBox ("Το ID δεν μπορεί να είναι κενό.")
        Sheets("Results").Range("U2").Select
        Exit Sub
    End If
    If Sheets("Results").Range("U3") = "" Then
        MsgBox ("Το κίτρινο κελί δεν μπορεί να είναι κενό.")
        Sheets("Results").Range("U3").Select
        Exit Sub
    End If
    Set ID = Sheets("Demographics").Range("A:A").Find(Sheets("Results").Range("U2").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not ID Is Nothing Then
        If ID.Offset(, 1) <> "" Then
            If MsgBox("Το αποτέλεσμα έχει ήδη δοθεί από " & ID.Offset(, 1) & "." & Chr(10) _
                & "Θες οπωσδήποτε να το αντικαταστήσεις;", vbYesNo + vbDefaultButton2) = vbYes Then
                ID.Offset(, 1) = Sheets("Results").Range("AB9")
            Else
                Sheets("Results").Range("U2:X2").ClearContents
                Sheets("Results").Range("U2:X2").Select
                MsgBox ("Βεβαιώσου ότι τα στοιχεία που καταχώρησες αφορούν το σωστό δείγμα! Αν όχι, πάτα καθαρισμό!")
                Exit Sub
            End If
        Else
            ID.Offset(, 1) = Sheets("Results").Range("AB9")
        End If
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="C:\Users\pc50\Desktop\New results\" & Range("AH1").Value _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    Else
        MsgBox ("Το ID " & Sheets("Results").Range("U2") & " δεν υπάρχει στη λίστα των ραντεβού." & Chr(10) & "Έλεγξε ότι έβαλες το σωστό ID.")
        Sheets("Results").Range("U2:X2").ClearContents
        Sheets("Results").Range("U2:X2").Select
        Exit Sub
    End If
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Would you mind checking it for possible mistakes that could create problems?

Try the macro and if it works, you're all set.

 

[Lux Aeterna]

Try the macro and if it works, you're all set.

It does! I'll mark your answer to my original question correct, as the credits for this macro goes all to you!

 

[mumps]

Glad it all worked out.