Make Column mandatory based on drop downs in previous columns - excel

This is my first time trying to code with VBA. I have a drop down list in cell A2 and a drop down list in cell B2.
If A2 and B2 are populated (NotBlank?) then the user must enter text into D2 (I would like to make sure the text is longer than 10 characters- hoping no one presses the space bar 10 times) or they can't save (BeforeSave?) else they can save.
I need to make it loop as well. That is, if A3 and B3 are not empty then D3 is mandatory etc. I hope this is clear. Please let me know if I need to explain more.
Here is the code. It works for that one cell, but how do I make it repeat? Do I change the range?
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If IsEmpty(Range("A2,B2")) = False Then
MsgBox "You must enter commentary to validate your ratings"
End If
End Sub

You need to loop through all used rows and check each cell on its own.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet 'specify which sheet here
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long 'find last used row in column A
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 2 To LastRow 'loop throug all used rows
If ws.Cells(iRow, "A").Value <> vbNullString And _
ws.Cells(iRow, "B").Value <> vbNullString And _
ws.Cells(iRow, "D").Value = vbNullString Then
MsgBox "You must enter commentary to validate your ratings. This file will not be saved!", vbExclamation
Cancel = True 'do not save
ws.Cells(iRow, "D").Select 'select missing cell
Exit For
End If
Next iRow
End Sub
Another idea
This will automatically select all missing cells, and has no loops.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim ConstantsInA As Range
Set ConstantsInA = ws.Range("A2:A" & LastRow).SpecialCells(xlCellTypeConstants)
Dim ConstantsInB As Range
Set ConstantsInB = ws.Range("B2:B" & LastRow).SpecialCells(xlCellTypeConstants)
Dim EmptyCellsInD As Range
Set EmptyCellsInD = ws.Range("D2:D" & LastRow).SpecialCells(xlCellTypeBlanks)
Dim MissingValues As Range
Set MissingValues = Intersect(ConstantsInA.EntireRow, ConstantsInB.EntireRow, EmptyCellsInD)
If Not MissingValues Is Nothing Then
MissingValues.Select 'select missing cells
MsgBox "You must enter commentary to validate your ratings. This file will not be saved!", vbExclamation
Cancel = True 'do not save
End If
End Sub

This should do what you want it to
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim c As Range
LastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For Each c In Sheets("Sheet1").Range("A2:A" & LastRow)
If c.Value <> "" And c.Offset(0, 1).Value <> "" And c.Offset(0, 3).Value = "" Then
MsgBox "You must enter commentary in column D" & c.Row & " to validate your ratings before saving"
Cancel = True
End If
Next
End Sub

Related

How to apply a condition to "used range" in whole column as a loop in excel using VBA?

I am beginner at VBA, I am stuck plz help. In this image(linked at the end of paragraph), I am trying to insert line above the cells which contains different name than the name of upper cell. Plz tell me if there is an easier way to do this or how to apply the given if else condition to whole "G" Column...
Still I am adding my code below if you don't need the image...
Sub ScanColumn()
'Application.ScreenUpdating = False
Dim varRange As Range
Dim currentCell As String
Dim upperCell As String
Dim emptyCell As String
currentCell = ActiveCell.Value
bottomCell = ActiveCell.Offset(1, 0).Value
emptyCell = ""
Dim intResult As Integer
intResult = StrComp(bottomCell, currentCell)
Dim emptyResult As Integer
emptyResult = StrComp(currentCell, emptyCell)
'I want to apply below condition to whole G column in used range
If emptyResult = 0 Then
ActiveCell.Select
ElseIf intResult = 0 Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1).EntireRow.Insert
ActiveCell.Offset(2, 0).Select
End If
End Sub
Here you have, just call the function "evaluateColumn" and pass the parameters, as example the "trial" sub.
Function evaluateColumn(column As String, startRow As Long, wsh As Worksheet)
Dim lastRow As Long
lastRow = wsh.Range(column & wsh.Rows.Count).End(xlUp).Row
Dim i As Long: i = startRow
Do While i < lastRow
If wsh.Cells(i, column).Value <> wsh.Cells(i + 1, column).Value And wsh.Cells(i, column).Value <> "" And wsh.Cells(i + 1, column).Value <> "" Then
wsh.Range(column & i + 1).EntireRow.Insert shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
i = i + 1
lastRow = lastRow + 1
End If
i = i + 1
Loop
End Function
Sub trial()
evaluateColumn "G", 2, ThisWorkbook.Worksheets("Sheet2")
End Sub
As you can see from the difference between my answer and the one below, your question isn't entirely clear. My code is an event procedure. It will run automatically, as you select a cell within the used range of column G.
If the value of the selected cell is the same as the cell below it the next row's cell will be selected.
If there is a value in either of the two cells, a blank row will be inserted and that row's cell selected. (If you want another row enable the row below the insertion.)
If either of the above conditions are true, do nothing and proceed with the selection the user made.
In order to let this code work it must be installed in the code sheet of the worksheet on which you want the action. It will not work if you install it in a standard code module, like Module1.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim TriggerRange As Range
Dim Off As Long ' offset from Target for selection
' if more than one cell is selected choose the first cell
If Target.Cells.CountLarge > 1 Then Set Target = ActiveCell
Set TriggerRange = Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
' this code will run only if a cell in this range is selected
' Debug.Print TriggerRange.Address(0, 0)
If Not Application.Intersect(Target, TriggerRange) Is Nothing Then
Application.EnableEvents = False
With Target
If .Value = .Offset(1).Value Then
Off = 1
ElseIf WorksheetFunction.CountA(.Resize(2, 1)) Then
Rows(.Row).Insert
' Off = 1 ' or -1 to change the selection
End If
.Offset(Off).Select
End With
Application.EnableEvents = True
End If
End Sub

How to enable Excel macros for only one sheet

In my excel sheet I am validating that a specific column should not be empty and its values should be unique. This validation should only be performed on Sheet1 but it is working for other sheets also.
My code is
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _ Cancel As Boolean)
Dim rngCell As Range
Dim lngLstRow As Long
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For Each rngCell In Range("A1:A" & lngLstRow)
If rngCell.Value = 0 Then MsgBox ("Please enter a name in cell " & rngCell.Address) rngCell.Select
End If
Next
End Sub
The second validation for unique values is done by data validation functionality in excel.
How about a ActiveWorksheet.name check ?
like
Dim Sh as Object, rngCell as Range, lngLstRow As Long
For Each Sh in WorkSheets
If Sh.Name = "SpecialName" Then 'YourCodeNext
lngLstRow = Sh.UsedRange.Rows.Count
For Each rngCell In Range("A1:A" & lngLstRow).Cells
If rngCell.Value = 0 Then MsgBox _
("Please enter a name in cell " & rngCell.Address) rngCell.Select
End If
Next rngCell
End If
Next Sh
Or if you know specific value of cell or range in your list.
For Each Sh in WorkSheets
If Sh.Range("K10").Value = "YourUnicValue" Then 'YourCodeNext
Also I'm not sure about your rngCell, if you want to check every cell in range, you need to use it like that.
For Each rngCell In Range("A1:A" & lngLstRow).Cells

Execute Procedure when Value in a Cell/Range Changes

I'm new to VBA and wrote the following codes according to my data set. The goal here is to execute my procedure if a cell/range gets changed by pasting new data into the worksheet, most probably the sheet will be empty as it will follow by a clear content procedure.
However, the code is not triggering the change event, I've tried several codes from Google, but none of them worked. Please note that my procedure gets me exactly the data I want in the format I want, however, if changes are needed, kindly let me know.
PLEASE HELP
1. Change event trigger - stored under Sheet1
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("A1")) Is Nothing Then
Application.EnableEvents = False
Call LoopandIfStatement
Application.EnableEvents = True
End If
End Sub
2. My procedure - stored under Sheet1 below the event above
Sub LoopandIfStatement()
Dim SHT As Worksheet
Set SHT = ThisWorkbook.Worksheets("CB")
MyLr = SHT.Cells(Rows.Count, 1).End(xlUp).Row
Dim I As Long
For I = 1 To MyLr
Dim O As Long
Dim U As Range
Set U = SHT.Range("A" & I)
If IsEmpty(SHT.Range("a" & I).Value) = False Then
SHT.Range("k" & I).Value = SHT.Range("A" & I).Value
Else
On Error GoTo ABC
SHT.Range("k" & I).Value = U.Offset(-1, 0)
End If
Next I
For O = 2 To MyLr
If SHT.Range("g" & O).Value = "Closing Balance" Then
SHT.Range("l" & O).Value = SHT.Range("j" & O).Value
End If
Next O
ABC:
End Sub
Results
This will trigger whenever new data is pasted in any cell of columns A to J
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("A:J")) Is Nothing Then
Application.EnableEvents = False
Call LoopandIfStatement
Application.EnableEvents = True
End If
End Sub
Regarding your sub LoopandIfStatement here are some suggestions:
Use Option explicit at the top of your modules (see this)
Declare all your variables (you're missing: Dim MyLr as long)
Try to name your variables to something understandable (e.g. instead of MyLr you could have lastRow)
If you need to exit a Sub you can use Exit Sub instead of a Goto ABC
EDIT:
Added code for the loop and the change worksheet event.
Paste it behind the CB Sheet module
Some highlights:
When you triggered the loop on each worksheet change, it would re-apply all the steps to all the cells. You can work with changed ranges using the Target argument/variable in the Worksheet_Change event
To loop through an existing range see the AddAccountBalanceToRange procedure
Try to think and plan your code in steps or actions that can be grouped
Use comments to describe the purpose of what you're doing
Remember to delete obsolete code (saw you had a copy of the procedure in a module)
Option Explicit
Private Sub CommandButton1_Click()
ThisWorkbook.Worksheets("Data").Columns("A:J").Copy
ThisWorkbook.Worksheets("CB").Range("A:J").PasteSpecial Paste:=xlPasteValues
End Sub
Private Sub CommandButton2_Click()
ThisWorkbook.Worksheets("CB").Range("A:L").ClearContents
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim targetUsedRange As Range
' Do something on non empty cells
Set targetUsedRange = Intersect(Target, Target.Parent.UsedRange)
If Not Intersect(Target, Me.Range("A:J")) Is Nothing Then
Application.EnableEvents = False
Call AddAccountBalance(targetUsedRange)
Application.EnableEvents = True
End If
End Sub
Private Sub AddAccountBalance(ByVal Target As Range)
Dim targetSheet As Worksheet
Dim evalRow As Range
Dim lastColumn As Long
Dim accountNumber As String
Dim balanceString As String
Dim narrative As String
Dim balanceValue As Long
balanceString = "Closing Balance"
' If deleting or clearing columns
If Target Is Nothing Then Exit Sub
' Do something if there are any values in range
If Application.WorksheetFunction.CountA(Target) = 0 Then Exit Sub
' Get the parent sheet of the cells that were modifid
Set targetSheet = Target.Parent
' Get the last empty cell column in row 1 -Cells(3 -> this is row 3)- In the sample book: column K
lastColumn = targetSheet.Cells(3, targetSheet.Columns.Count).End(xlToLeft).Column
' Loop through each of the rows that were modified in range
For Each evalRow In Target.Cells.Rows
' Do something if account number or narrative are not null
If targetSheet.Cells(evalRow.Row, 1).Value <> vbNullString Or targetSheet.Cells(evalRow.Row, 7).Value <> vbNullString Then
' Store columns values in evaluated row
accountNumber = targetSheet.Cells(evalRow.Row, 1).Value
narrative = targetSheet.Cells(evalRow.Row, 7).Value
If IsNumeric(targetSheet.Cells(evalRow.Row, 10).Value) Then balanceValue = targetSheet.Cells(evalRow.Row, 10).Value
' Add account number
If accountNumber <> vbNullString Then
targetSheet.Cells(evalRow.Row, lastColumn).Value = accountNumber
End If
' Add closing balance
If narrative = balanceString Then
targetSheet.Cells(evalRow.Row, lastColumn).Value = targetSheet.Cells(evalRow.Row, 1).Offset(-1, 0).Value
targetSheet.Cells(evalRow.Row, lastColumn).Offset(0, 1).Value = balanceValue
End If
' Format last two columns (see how the resize property takes a single cell and expands the range)
With targetSheet.Cells(evalRow.Row, lastColumn).Resize(, 2).Interior
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
' Auto fit last column (K) (you could use the resize property as in the previous statement)
targetSheet.Columns(lastColumn).EntireColumn.AutoFit
End If
Next evalRow
End Sub
Public Sub AddAccountBalanceToRange()
Dim targetSheet As Worksheet
Dim evalRange As Range
Set targetSheet = ThisWorkbook.Worksheets("CB")
Set evalRange = targetSheet.Range("A1:A42")
AddAccountBalance evalRange
End Sub

VBA code to Highlight duplicate columns in excel

I am working on a VBA to validate the contents of an excel sheet. I want unique values in the first column, and to be able to determine the validity of these values using the foreign keys on another column. This is what I have to validate for unique entries:
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.CountIf(Range("A:A"), Target) > 1 Then
MsgBox "Duplicate Data", vbCritical, "Remove Data"
Target.Value = ""
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
It prevents duplicate entry in the first row. But what I really want is to be able to detect duplicate by running the macros on an already filled spreadsheet, and to have invalid fields highlighted.
This should do the trick:
Sub sbHighlightDuplicatesInColumn()
Dim lastCol As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastCol = Sheets("Sheet1").Range("A1").SpecialCells(xlCellTypeLastCell).Column
For iCntr = 1 To lastCol
If Cells(1, iCntr) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(1, iCntr), Range(Cells(1, 1), Cells(1, iCntr)), 0)
If iCntr <> matchFoundIndex Then
Sheets("Sheet1").Cells(1, iCntr).Interior.Color = vbYellow
End If
End If
Next
End Sub

do loop error in VBA code

I'm pretty new at VBA so I'm sure I'm missing something easy... I am getting a compile error "Loop without Do"
The function being called GrabDataFromMinutes I have tested successfully on it's own. Any help is appreciated, Thanks!
Public Sub CopyAllData()
Dim Location As String
Location = ActiveCell.Address
Dim CellValue As String
CellValue = ActiveCell.Value
Do
If IsEmpty(CellValue) = True Then 'If cell is empty skip row'
ActiveCell.Offset(rowOffset:=1, ColumnOffset:=-1).Activate
Loop
If Location <> "C350" Then 'run the command unless EOF'
Application.Run ("GrabDataFromMinutes")
MsgBox "I got here"
Location = ActiveCell.Address
Loop
End If
Exit Do
End Sub
As rightly mentioned by Scott you need to place the LOOP statement in the respective place. Click Here
Your code should be like this
Public Sub CopyAllData()
Dim Location As String
Location = ActiveCell.Address
Dim CellValue As String
CellValue = ActiveCell.Value
Do
If IsEmpty(CellValue) = True Then 'If cell is empty skip row'
ActiveCell.Offset(rowOffset:=1, ColumnOffset:=-1).Activate
If Location <> "C350" Then 'run the command unless EOF'
Application.Run ("GrabDataFromMinutes")
MsgBox "I got here"
Location = ActiveCell.Address
End If
End If
Loop
End Sub
This is the end solution to my own problem. The information provided by other answers contributed to fixing my problems. Thanks Everyone!
Public Sub CopyAllData()
'Declarations'
Dim CellValue As String
Dim LastRow As Integer
Dim CurrentRow As Integer
Application.Run ("CopyMinuteHeaders") 'Copy Headers and setup sheet'
'Initialize values'
CellValue = ActiveCell.Value
CurrentRow = ActiveCell.Row
LastRow = ActiveSheet.UsedRange.Rows.Count
LastRow = LastRow + 1
Do While LastRow <> CurrentRow
If CurrentRow >= LastRow Then
Exit Sub
End If
If CellValue = "" Then 'If cell is empty skip row'
Do While CellValue = "" 'Skip multiple rows that are empty'
ActiveCell.Offset(rowOffset:=1, ColumnOffset:=0).Activate
CellValue = ActiveCell.Value
Loop
End If
If CurrentRow <> LastRow Then
Application.Run ("GrabDataFromMinutes")
CurrentRow = ActiveCell.Row
CellValue = ActiveCell.Value
End If
Loop
End Sub
I don't know what your GrabDataFromMinutes macro does, I would assume it deals with the active cell though. Usually I would try not to supply a code using select or activate. If you were to supply the code for GrabDataFromMinutes maybe a better solution could be found for you.
In the meantime practice with this code, it will select only the non-blank cells in column A and call the otherMacro.
Sub LoopNonBlanks()
Dim Lstrw As Long
Dim Rng As Range
Dim c As Range
Lstrw = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range("A2:A" & Lstrw).SpecialCells(xlCellTypeConstants, 23)
For Each c In Rng.Cells
c.Select
otherMacro 'calls the otherMacro
Next c
End Sub
Sub otherMacro()
MsgBox "This is the other macro " & ActiveCell.Address & " value is ..." & ActiveCell.Value
End Sub

Resources