I currently have this piece of code to insert a new row, use validation on the second cell in the row:
Sub RICH()
'
' Macro3 Macro
Dim ws As Worksheet
Dim fnd As Range
Dim fndstr As String
fndstr = "Targeted Premium Ads"
Set ws = Worksheets("Inputsheet")
Set fnd = ws.Columns(2).Find(what:=fndstr, After:=ws.Range("B11"), _
LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByColumns, _
searchdirection:=xlNext, MatchCase:=False)
If Not fnd Is Nothing Then
Rows(fnd.Row - 1).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B" & fnd.Row - 2).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Suppliers!$B$2:$B$178"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End Sub
However, I now want to insert two functions, say: =sum(A$4,B$5), and =sum(A$9, C$3) respectively into columns N, O of this newly outputted row. What would be the right approach to this?
How about:
Range("N" & fnd.Row - 2).Formula = "=SUM(A$4,B$5)"
Range("O" & fnd.Row - 2).Formula = "=SUM(A$9,C$3)"
(assuming fnd.Row - 2 is the row where you want to place the formulae).
Related
I'm trying to replace all cells in a column with a dropdown list for using an excel macro. I'm also trying to use dynamic range as I don't know how long the list is at all times. This is my code as of right now:
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Set sht = Worksheets("*Name of main sheet*")
Set StartCell = Range("A1")
'Find Last Row and Column
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column
'Select Range
Worksheets("*Name of main sheet*").Activate
'replace "J2" with the cell you want to insert the drop down list
With Range(StartCell, sht.Cells(LastRow, LastColumn))
.Delete
'replace "=A1:A6" with the range the data is in.
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Sheet1!A1:A6"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
I'm creating the lists with all the options for the drop down in a separate tab called Sheet1.
add .Validation at the end of With Range(StartCell, sht.Cells(LastRow, LastColumn)) and use $ to keep rows reference fixed
so the whole With-End block With becomes:
With Range(StartCell, sht.Cells(LastRow, LastColumn)).Validation
.Delete
'replace "=A1:A6" with the range the data is in.
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Sheet1!A$1:A$6"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
if you need to keep dropdowns list dynamic with Sheet1 column A not blank values then you could go as follows:
Dim LastRow As Long
Dim LastColumn As Long
Dim sourceSht As Worksheet
Set sourceSht = Worksheets("Sheet1")
With Worksheets("Name of main sheet")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
With .Range("A1", .Cells(LastRow, LastColumn)).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=" & sourceSht.name & "!" & sourceSht.Range("A1", sourceSht.Cells(sourceSht.Rows.Count, 1).End(xlUp)).Address(True, False)
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End With
I am having trouble with getting a data validation list to adjust based on the last column from content in row 5.
Here is what i have currently.
Sub DataRange_F() 'Foundation Drop Down List
Application.ScreenUpdating = False
Dim LastCol As Long
Dim Rng As Range
Dim WholeRng As Range
Dim ws As Worksheet
Dim wsR As Worksheet
Set ws = ThisWorkbook.Worksheets("Add New")
Set wsR = ThisWorkbook.Worksheets("Foundation Plates")
wsR.Activate
Set Rng = Cells
LastCol = Rng.Find(What:="*", After:=Rng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
Set WholeRng = Range(Cells(5, "C"), Cells(5, LastCol))
ws.Activate
With ws.Range("E8").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=WholeRng
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Set ws = Nothing
Application.ScreenUpdating = True
End Sub
It keeps stopping at the Formula1:= part. This is where i am stuck. How can i add my range in that Formula? Or is there another way?
Thanks
Try it like this...
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=" & "'" & wsR.Name & "'!" & WholeRng.Address
Try it as,
..., Formula1:=Chr(61) & WholeRng.Cells(1).Address(external:=true), Formula2:=Chr(61) & WholeRng.Cells(WholeRng.Cells.Count).Address(external:=true)
This is what i got to work.
Function GetColumnLetter(colNum As Long) As String
Dim vArr
vArr = Split(Cells(1, colNum).Address(True, False), "$")
GetColumnLetter = vArr(0)
End Function
Sub DataRange()
Application.ScreenUpdating = False
Dim startCol As String
Dim startRow As Long
Dim lastCol As Long
Dim myCol As String
Dim rng As Range
Dim cell As Range
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Worksheets("Foundation Plates")
Dim sht7 As Worksheet
Set sht7 = ThisWorkbook.Worksheets("Legend")
Call Unprotect
sht2.Activate
startCol = "C"
startRow = 5
lastCol = sht2.Cells(5, sht2.Columns.Count).End(xlToLeft).Column
myCol = GetColumnLetter(lastCol)
Set rng = sht2.Range(startCol & startRow & ":" & myCol & "5")
'For error checking the range
'MsgBox rng.Address
sht7.Activate
With sht7.Range("F8").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=" & "'" & sht2.Name & "'!" & rng.Address
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Call Protect
sht2.Activate
Set sht2 = Nothing
Set sht7 = Nothing
Set rng = Nothing
Application.ScreenUpdating = True
End Sub
My plan is to enter data on a specific sheet(List) and automatically sort by alphabetical order, then create a data validation on the first sheet (TicketSheet).
When I enter any date and save I can't open the file again because it crashes.
I developed the following code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("$A:$F")) Is Nothing Then
Dim x As Range
Set x = Cells(2, Target.Column)
Dim y As Range
Set y = Cells(1000, Target.Column)
If Target.Column = 1 Or Target.Column = 4 Or Target.Column = 6 Then
Range(x, y).Sort Key1:=Target, Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End If
End If
Call AddData
Call AddData1
Call AddData2
End Sub
Sub AddData()
Dim Lrow As Single
Dim Selct As String
Dim Value As Variant
Lrow = Worksheets("List").Range("A" & Rows.Count).End(xlUp).Row
For Each Value In Range("A2:A" & Lrow)
Selct = Selct & "," & Value
Next Value
Selct = Right(Selct, Len(Selct) - 1)
With Worksheets("TicketSheet").Range("C4").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Selct
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Sub AddData1()
Dim Lrow1 As Single
Dim Selct1 As String
Dim Value As Variant
Lrow1 = Worksheets("List").Range("D" & Rows.Count).End(xlUp).Row
For Each Value In Range("D2:D" & Lrow1)
Selct1 = Selct1 & "," & Value
Next Value
Selct1 = Right(Selct1, Len(Selct1) - 1)
With Worksheets("TicketSheet").Range("C3").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Selct1
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Sub AddData2()
Dim Lrow2 As Single
Dim Selct2 As String
Dim Value As Variant
Lrow2 = Worksheets("List").Range("F" & Rows.Count).End(xlUp).Row
For Each Value In Range("F2:F" & Lrow2)
Selct2 = Selct2 & "," & Value
Next Value
Selct2 = Right(Selct2, Len(Selct2) - 1)
With Worksheets("TicketSheet").Range("C5").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Selct2
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub]
First off, you need to disable events. The Worksheet_Change event macro is triggered by a change of values. If you are going to start changing values inside a Worksheet_Change then disabling events stops the macro from triggering itself.
Additionally, the Target is the cell or cells that have been changed. Your code does not allow for the latter; it only deals with situations where Target is a single cell. For the time being, discard large changes (like those in a row deletion or sort operation).
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("$A:$F")) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim x As Range, y As Range
Set x = Cells(2, Target.Column)
Set y = Cells(1000, Target.Column)
If Target.Column = 1 Or Target.Column = 4 Or Target.Column = 6 Then
'you really should know if you have column header labels or not
Range(x, y).Sort Key1:=Target, Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
Call AddData
Call AddData1
Call AddData2
End If
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
That should get you started. I will look deeper into your other sub procedures later but I will remark that it seems like you have an awful lot going on to have initiated by a Worksheet_Change.
Am quite new to VBA and am piecing together my developments one step at at time searching for answers online but have hit a snag.
I'm struggling to understand how the creation of the data validation list code works. The beginning "With WrkBook.Range("H3").Validation" is where I'm putting the drop down list? Seems 'yes' from one posting, but another seemed to have the "With" followed by the actual range which contains the list. Secondly, the "Formula1:=..." I believe is also the location of the list. However, I seem to be only able to include the first cell in my list as being included in the list. Thanks in advance for any help.
Dim WrkBook As Worksheet
Dim LastCellRowNumber As Integer
Dim ListRng As Range
Dim Rng As Range
Set WrkBook = Worksheets("Misc Ref")
'Find
WrkBook.Activate
Range("A100000").Select
Range(Selection, Selection.End(xlUp)).Select
LastCellRowNumber = ActiveCell.Row
ActiveSheet.Cells(LastCellRowNumber, 1).Select
Set ListRng = WrkBook.Range(Cells(2, 1), Cells(LastCellRowNumber, 1))
With WrkBook.Range("H3").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=WrkBook.ListRng
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
In this line:
Set ListRng = WrkBook.Range(Cells(2, 1), Cells(LastCellRowNumber, 1))
you already set or assign a Range Object referenced at WrkBook sheet object.
So you don't have to use WrkBook.ListRng in assigning the Formula1 argument.
Also, Formula1 argument is suppose to be the address of the source range in the form of string.
So it should be something like:
Formula1:= "=" & ListRng.Address
This will fail though if the worksheet your putting the validation list is not the same worksheet of the source list. So you might want to add:
Formula1:= "=" & ListRng.Address(, , xlA1, True)
That will give you the Sheet name as well. HTH.
Edit2: Based on comments and no need to use Split function.
Sub test()
Dim r As Range, lrow As Long
With Sheets("Misc Ref")
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set r = .Range("A2:A" & lrow)
End With
'Debug.Print "=" & r.Address(, , xlA1, True)
With Sheets("Summary").Range("H10").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & r.Address(, , xlA1, True)
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Setting the Address property External argument to True includes the full path.
But if you assign it to a validation formula, it automatically disregards the Workbook name.
So there is no need to use Split Function. No need to worry the apostrophe then. HTH.
I have found that code (on: http://www.siddharthrout.com/2011/07/29/excel-data-validationcreate-dynamic-dependent-lists-vba/) really useful:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, LastRow As Long, n As Long
Dim MyCol As Collection
Dim SearchString As String, TempList As String
Application.EnableEvents = False
On Error GoTo Whoa
'~~> Find LastRow in Col A
LastRow = Range("A" & Rows.Count).End(xlUp).Row
If Not Intersect(Target, Columns(1)) Is Nothing Then
Set MyCol = New Collection
'~~> Get the data from Col A into a collection
For i = 1 To LastRow
If Len(Trim(Range("A" & i).Value)) <> 0 Then
On Error Resume Next
MyCol.Add CStr(Range("A" & i).Value), CStr(Range("A" & i).Value)
On Error GoTo 0
End If
Next i
'~~> Create a list for the DV List
For n = 1 To MyCol.Count
TempList = TempList & "," & MyCol(n)
Next
TempList = Mid(TempList, 2)
Range("D1").ClearContents: Range("D1").Validation.Delete
'~~> Create the DV List
If Len(Trim(TempList)) <> 0 Then
With Range("D1").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=TempList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
'~~> Capturing change in cell D1
ElseIf Not Intersect(Target, Range("D1")) Is Nothing Then
SearchString = Range("D1").Value
TempList = FindRange(Range("A1:A" & LastRow), SearchString)
Range("E1").ClearContents: Range("E1").Validation.Delete
If Len(Trim(TempList)) <> 0 Then
'~~> Create the DV List
With Range("E1").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=TempList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
'~~> Function required to find the list from Col B
Function FindRange(FirstRange As Range, StrSearch As String) As String
Dim aCell As Range, bCell As Range, oRange As Range
Dim ExitLoop As Boolean
Dim strTemp As String
Set aCell = FirstRange.Find(what:=StrSearch, LookIn:=xlValues, _
lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
ExitLoop = False
If Not aCell Is Nothing Then
Set bCell = aCell
strTemp = strTemp & "," & aCell.Offset(, 1).Value
Do While ExitLoop = False
Set aCell = FirstRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
strTemp = strTemp & "," & aCell.Offset(, 1).Value
Else
ExitLoop = True
End If
Loop
FindRange = Mid(strTemp, 2)
End If
End Function
That code works but when I try to put the DV list to another sheet and change the cells to write on, it doesn't work correctly...
When I select the option what I want to the list, the selected option is not written on the cell.
So the program runs without any problem but the result, it's not what i want.
The rearranged code is:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, LastRow As Long, n As Long
Dim MyCol As Collection
Dim SearchString As String, Templist As String
Application.EnableEvents = False
On Error GoTo Whoa
' Find LastRow in Col A
LastRow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
If Not Intersect(Target, Columns(1)) Is Nothing Then
Set MyCol = New Collection
' Get the data from Col A into a collection
For i = 2 To LastRow
If Len(Trim(Sheet2.Range("A" & i).Value)) <> 0 Then
On Error Resume Next
MyCol.Add CStr(Sheet2.Range("A" & i).Value), CStr(Sheet2.Range("A" & i).Value)
On Error GoTo 0
End If
Next i
' Create a list for the Data Validation List
For n = 1 To MyCol.Count
Templist = Templist & "," & MyCol(n)
Next
Templist = Mid(Templist, 2)
Range("A2").ClearContents: Range("A2").Validation.Delete
' Create the Data Validation List
If Len(Trim(Templist)) <> 0 Then
With Range("A2").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Templist
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
' Capturing change in cell A2
ElseIf Not Intersect(Target, Range("A2")) Is Nothing Then
SearchString = Range("A2").Value
Templist = FindRange(Sheet2.Range("A2:A" & LastRow), SearchString)
Range("B2").ClearContents: Range("B2").Validation.Delete
If Len(Trim(Templist)) <> 0 Then
' Create the DV List
With Range("B2").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Templist
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
' Function required to find the list from Col B
Function FindRange(FirstRange As Range, StrSearch As String) As String
Dim aCell As Range, bCell As Range, oRange As Range
Dim ExitLoop As Boolean
Dim strTemp As String
Set aCell = FirstRange.Find(what:=StrSearch, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:= _
xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
ExitLoop = False
If Not aCell Is Nothing Then
Set bCell = aCell
strTemp = strTemp & "," & aCell.Offset(, 1).Value
Do While ExitLoop = False
Set aCell = FirstRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
strTemp = strTemp & "," & aCell.Offset(, 1).Value
Else
ExitLoop = True
End If
Loop
FindRange = Mid(strTemp, 2)
End If
End Function
Is there somebody who has any idea if I have to change something more? Is there something tricky that I'm missing?