Could someone help me with this code please?

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,375
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I don't understand vba code yet so could someone please help me with this code as it is giving me an error, as explained below?

Code:
  Option Explicit
     Private Sub TextBox1_Change()
      Dim hBox As Double, h As Double, h5 As Double, H6 As Double
      h5 = Me.Rows(5).RowHeight
      H6 = Me.Rows(6).RowHeight      
      With Me.Shapes("TextBox1")
          hBox = .Height
          .Top = Me.Rows(4).Top + 10
      End With
      h = hBox - h5 - H6
      If h > 0 Then
          Me.Rows("7:8").RowHeight = h / 2
      Else
          Me.Rows("7:8").RowHeight = 0
      End If
  End Sub
  
  Private Sub cmdAddRow_Click()  
  'ActiveSheet.Unprotect Password:="npssadmin"
  Dim ws As Worksheet
  Set ws = ActiveSheet
  Dim tbl As ListObject
  Set tbl = ws.ListObjects("npss_quote")
  'add a row at the end of the table
  tbl.ListRows.Add  
  'ActiveSheet.Protect Password:="npssadmin"
  Application.EnableEvents = True
  End Sub
  
  Private Sub cmdDeleteRow_Click()  
  'ActiveSheet.Unprotect Password:="npssadmin"
      Dim ans As Long
      With ActiveSheet.ListObjects("npss_quote").DataBodyRange
          ans = .Rows.Count
          If ans > 1 Then .Rows(ans).Delete
          If ans = 1 Then .Rows(1).Cells.SpecialCells(xlCellTypeConstants).ClearContents
      End With  
      'Selection.ListObject.ListRows(6).Delete
      'ActiveSheet.Protect Password:="npssadmin"
  Application.EnableEvents = True
  End Sub
  
  
  Private Sub cmdDelRow_Click()
      Rows("10:10").Select
      Selection.Delete Shift:=xlUp    
  End Sub
  
  Private Sub cmdDelSelect_Click()  
      Dim rng As Range      
      On Error Resume Next
      With Selection.Cells(1)
          Set rng = Intersect(.EntireRow, ActiveCell.ListObject.DataBodyRange)
          On Error GoTo 0
          If rng Is Nothing Then
              MsgBox "Please select a cell within a row that you want to delete.", vbCritical
          Else
              rng.Delete xlShiftUp
          End If
      End With
  Application.EnableEvents = True  
  End Sub
  
  
  Private Sub cmdAddNoteRow_Click()
      Rows("10:10").Select
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
  End Sub
  
  Private Sub cmdG_Click()
  imgJ.Visible = False
  imgG.Visible = True
  End Sub
  
  Private Sub cmdHide_Click()
  cmdAddRow.Visible = False
  cmdDeleteRow.Visible = False
  cmdDelSelect.Visible = False
  cmdHide.Visible = False
  End Sub
  
  Private Sub cmdJ_Click()
  imgG.Visible = False
  imgJ.Visible = True
  
  End Sub
  
  Private Sub cmdNoSig_Click()
  imgG.Visible = False
  imgJ.Visible = False
  End Sub
  
  Sub HidePic()      
  Dim myImage As Shape
  Set myImage = ActiveSheet.Shapes("Picture 1")  
   ActiveSheet.Shapes("Picture 1").Visible = False
  End Sub
  End Sub
  
  Private Sub CommandButton1_Click()
  Dim myImage As Shape
  Dim cellLocation As Range  
  Set myImage = ActiveSheet.Shapes("imgj")
  Set cellLocation = ActiveSheet.Range("F43")
  ActiveSheet.Shapes("imj").Visible = True  
  myImage.Top = cellLocation.Top + (cellLocation.Height / 2) - (myImage.Height / 2)
  myImage.Left = cellLocation.Left + (cellLocation.Width / 2) - (myImage.Width / 2)  
  End Sub
  
  Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("A:A")) Is Nothing Then
  Application.EnableEvents = False
  If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
  If Target.Value < Date Then
  ans = MsgBox("This input is older than today !....Are you sure that is what you want ???", vbYesNo)
  If ans = vbNo Then Target.Value = ""
  End If
  End If
  Application.EnableEvents = True  
  End Sub
  
  Sub Reset_Me()
  Application.EnableEvents = True
  End Sub

It used to work fine and I don’t think I have changed anything but now it gives me an error when I try and update a combo box on the form. The vba editor appears with the error box visible and it says “variable not defined”.

The ans is highlighted:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
Application.EnableEvents = False
If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
If Target.Value < Date Then
ans = MsgBox("This input is older than today !....Are you sure that is what you want ???", vbYesNo)
If ans = vbNo Then Target.Value = ""
End If
End If
Application.EnableEvents = True

I don’t know what to do to fix this, could someone help me please? I looked at a previous version and it worked fine but it didn't appear to be any different.

Thanks,
Dave
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Try the below or maybe remove Option Explicit.

With Option Explicit you must declare all variables, though i'm not sure you need one for a msgbox.

Code:
  Option Explicit
     Private Sub TextBox1_Change()
      Dim hBox As Double, h As Double, h5 As Double, H6 As Double
      h5 = Me.Rows(5).RowHeight
      H6 = Me.Rows(6).RowHeight
      With Me.Shapes("TextBox1")
          hBox = .Height
          .Top = Me.Rows(4).Top + 10
      End With
      h = hBox - h5 - H6
      If h > 0 Then
          Me.Rows("7:8").RowHeight = h / 2
      Else
          Me.Rows("7:8").RowHeight = 0
      End If
  End Sub
  
  Private Sub cmdAddRow_Click()
  'ActiveSheet.Unprotect Password:="npssadmin"
  Dim ws As Worksheet
  Set ws = ActiveSheet
  Dim tbl As ListObject
  Set tbl = ws.ListObjects("npss_quote")
  'add a row at the end of the table
  tbl.ListRows.Add
  'ActiveSheet.Protect Password:="npssadmin"
  Application.EnableEvents = True
  End Sub
  
  Private Sub cmdDeleteRow_Click()
  'ActiveSheet.Unprotect Password:="npssadmin"
      Dim ans As Long
      With ActiveSheet.ListObjects("npss_quote").DataBodyRange
          ans = .Rows.Count
          If ans > 1 Then .Rows(ans).Delete
          If ans = 1 Then .Rows(1).Cells.SpecialCells(xlCellTypeConstants).ClearContents
      End With
      'Selection.ListObject.ListRows(6).Delete
      'ActiveSheet.Protect Password:="npssadmin"
  Application.EnableEvents = True
  End Sub
  
  
  Private Sub cmdDelRow_Click()
      Rows("10:10").Select
      Selection.Delete Shift:=xlUp
  End Sub
  
  Private Sub cmdDelSelect_Click()
      Dim rng As Range
      On Error Resume Next
      With Selection.Cells(1)
          Set rng = Intersect(.EntireRow, ActiveCell.ListObject.DataBodyRange)
          On Error GoTo 0
          If rng Is Nothing Then
              MsgBox "Please select a cell within a row that you want to delete.", vbCritical
          Else
              rng.Delete xlShiftUp
          End If
      End With
  Application.EnableEvents = True
  End Sub
  
  
  Private Sub cmdAddNoteRow_Click()
      Rows("10:10").Select
      Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
  End Sub
  
  Private Sub cmdG_Click()
  imgJ.Visible = False
  imgG.Visible = True
  End Sub
  
  Private Sub cmdHide_Click()
  cmdAddRow.Visible = False
  cmdDeleteRow.Visible = False
  cmdDelSelect.Visible = False
  cmdHide.Visible = False
  End Sub
  
  Private Sub cmdJ_Click()
  imgG.Visible = False
  imgJ.Visible = True
  
  End Sub
  
  Private Sub cmdNoSig_Click()
  imgG.Visible = False
  imgJ.Visible = False
  End Sub
  
  Sub HidePic()
  Dim myImage As Shape
  Set myImage = ActiveSheet.Shapes("Picture 1")
   ActiveSheet.Shapes("Picture 1").Visible = False
  End Sub
  End Sub
  
  Private Sub CommandButton1_Click()
  Dim myImage As Shape
  Dim cellLocation As Range
  Set myImage = ActiveSheet.Shapes("imgj")
  Set cellLocation = ActiveSheet.Range("F43")
  ActiveSheet.Shapes("imj").Visible = True
  myImage.Top = cellLocation.Top + (cellLocation.Height / 2) - (myImage.Height / 2)
  myImage.Left = cellLocation.Left + (cellLocation.Width / 2) - (myImage.Width / 2)
  End Sub
  
  Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("A:A")) Is Nothing Then
  Application.EnableEvents = False
  If Target.Cells.CountLarge > 1 Or IsEmpty(Target) Then Exit Sub
  If Target.Value < Date Then
  If MsgBox("This input is older than today !....Are you sure that is what you want ???", vbYesNo) = vbNo Then
  Target.Value = ""
  End If
  Application.EnableEvents = True
  End Sub
  
  Sub Reset_Me()
  Application.EnableEvents = True
  End Sub
 
Upvote 0
Code:
ans = MsgBox("This input is older than today !....Are you sure that is what you want ???", vbYesNo)
If ans = vbNo Then target.Value = ""
End If

to
  
If MsgBox("This input is older than today !....Are you sure that is what you want ???", vbYesNo) = vbNo Then
target.Value = ""
End If

*Realized there are 2 End If's missing after that though, you'll need to add them
 
Last edited:
Upvote 0
I fixed it, I just added Dim ans as Long at the start after
Private Sub Worksheet_Change(ByVal Target As Range)
 
Upvote 0
What would be the better option? Your solution or mine?
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,907
Messages
6,175,300
Members
452,633
Latest member
DougMo

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