I am just a newbie in excel and vb scripts and have added ActiveX checkbox control with a custom function to color the row if the checkbox is checked and remove it if unchecked.
Macro code:
Public Sub GenerateCheckBox()
Dim i As Integer
Dim linkedcell
linkedcell = "B"
initialTop = 15
totalRow = (Cells(Rows.Count, 4).End(xlUp).row - 1)
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
Dim checkbox As OLEObject
Range("A:C").Insert
Range("A1").Value = "Resolved"
For i = 1 To totalRow
activeRow = i
Set checkbox = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=0, Top:=initialTop, Width:=13, Height:=15)
checkbox.linkedcell = linkedcell & activeRow
checkbox.Object.Caption = ""
checkbox.Object.BackStyle = 0
checkbox.Object.Value = False
initialTop = initialTop + 15
ws.Range("C" & activeRow).Formula = "=ColorRowIF(B" & activeRow & "=True)"
Next i
End Sub
Public Function ColorRowIF(Condition As Boolean, Optional r As Integer = 100, Optional g As Integer = 255, Optional b As Integer = 4) As String
Dim row As Integer
row = Application.Caller.row
If Condition = True Then
' Paints the checked row with color
ActiveSheet.Evaluate "ColorRow(" & row & ", " & r & ", " & g & ", " & b & ")"
Else
'Removes the color from the unchecked row
ActiveSheet.Evaluate "RemoveRowColor(" & row & ")"
End If
ColorRowIF = Condition
End Function
Sub DeleteAll()
Dim obj As OLEObject
For Each obj In ActiveSheet.OLEObjects
obj.Delete
Next obj
Columns("A:C").Delete
End Sub
This code works perfectly until the rows exceed more than 2000. After 2000 rows, column C returns the "#VALUE!" error for all the existing cells and does not evaluate the result.
Also, I have added a method to delete the ActiveX checkbox and the first 3 columns which also work perfectly fine for 2000 rows added with the checkbox and formulas.
After that VB throws below error:
Run-time error '-2147319765 (8002802b)':
Automation error
Element not found
When I click the debug option the cursor shows For Each obj In ActiveSheet.OLEObjects method as having the error.
Related
i need to make rows and columns mandatory before close
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim lr As Long
Dim r As Long
' Activate correct sheet
' Sheets("Sheet1").Activate
' Find last row in column A with data
lr = Cells(Rows.Count, "A").End(xlUp).Row
' Loop through all rows with data in column A
For r = 2 To lr
' Check to see if column A is not zero
If Cells(r, "A") <> 0 Then
' Check to see that columns B and C are not empty
If Cells(r, "B") = "" Or Cells(r, "C") = "" Then
Cancel = True
MsgBox "Please fill in columns B and C", vbOKOnly, "ROW " & r & " INCOMPLETE!!!"
End If
End If
Next r
End Sub
I made it a bit faster and more user friendly using:
Arrays to iterate data.
a single error message at the end rather than several.
I also made the requested change to allow code to work with and column width requirements. Just change the ColumnsToCheck = 6 to however many columns.
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim lRow As Long
Dim I As Long
Dim ColumnsToCheck As Long
Dim MissedItem As Boolean
Dim Mitem As Boolean
Dim M As Long
Dim SrcRG As Range
Dim SrcArr
Dim OutMessage As String
' *** This is the number of columns you are checking INCLUDING Column A
ColumnsToCheck = 6 'Minimum = 2
' Find last row in column A with data
lRow = Cells(Rows.Count, "A").End(xlUp).Row
Set SrcRG = Range("A1").Resize(lRow, ColumnsToCheck)
SrcArr = SrcRG
MissedItem = False
OutMessage = "Please fill in data columns 2 through " & ColumnsToCheck & "." & vbCrLf & _
"Missing Data found in the following locations." & vbCrLf
' Loop through all rows with data in column A
For I = 2 To lRow
' Check to see if column A is not zero
If SrcArr(I, 1) <> 0 Then
' Check to see that columns B and C are not empty
For M = 2 To ColumnsToCheck
Debug.Print SrcArr(I, M)
If SrcArr(I, M) = "" Then Mitem = True
Next M
If Mitem = True Then
MissedItem = True
OutMessage = OutMessage & vbCrLf & _
" Missing data at row # " & I
Mitem = False
End If
End If
Next I
If MissedItem = True Then
Cancel = True
MsgBox OutMessage, vbOKOnly, "Error: Missing Data"
End If
End Sub
I have this problem. I've only been doing VBA for about a week. I have a workbook where I created a button that copies a certain range in a row and pastes it into a table on another sheet. My problem is this: do I need to create a module for each button, or can I somehow simplify the code to create the same buttons for each row on the first sheet?
Sub SelectRangea()
Sheets("Tournaments").Select
Range("B4:G4").Select
Application.CutCopyMode = False
Selection.Copy
With Sheets("Results")
lst = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lst).PasteSpecial xlPasteColumnWidths
.Range("A" & lst).PasteSpecial xlPasteValues
End With
End Sub
You'll need to adjust the code accordingly but this will add a set of buttons for you as well as tell you the cell that the button was pressed from ...
Public Sub AddButtons()
Dim lngRow As Long, rngCell As Range, objButton As Shape
For lngRow = 1 To 10
Set rngCell = Sheet1.Cells(lngRow, 1)
Set objButton = Sheet1.Shapes.AddFormControl(xlButtonControl, rngCell.Left, rngCell.Top, rngCell.Width, rngCell.Height)
objButton.OnAction = "ButtonPushAction"
Next
End Sub
Public Sub ButtonPushAction()
Dim objCaller As Shape
Set objCaller = Sheet1.Shapes(Application.Caller)
MsgBox "Top Cell = " & objCaller.TopLeftCell.Address & vbCrLf & _
"Row = " & objCaller.TopLeftCell.Cells(1, 1).Row & vbCrLf & _
"Column = " & objCaller.TopLeftCell.Cells(1, 1).Column, vbInformation, "Button Push"
End Sub
Do I need to create a module for each button?
We only need to create one module containing the macros needed by the buttons and we can use the same macro for all the buttons.
Can I somehow simplify the code to create the same buttons for each row on the first sheet?
All the buttons should be identical, except their names. They can be copies of each other.
I assume we want to copy the row clicked. So I changed SelectRangea:
' Copy the code below to a standard module
Public Sub SelectRangea(RowNumber As Integer)
' Copy the row clicked
Sheets("Tournaments").Select
Range("B" & RowNumber & ":G" & RowNumber).Select
Application.CutCopyMode = False
Selection.Copy
' Paste the row clocked
With Sheets("Results")
lst = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lst).PasteSpecial xlPasteColumnWidths
.Range("A" & lst).PasteSpecial xlPasteValues
End With
End Sub
And here is the click handler for the buttons:
' Copy the code below to a standard module
Public Sub MyButton_Click()
Dim Btn As Object
Dim RowNumber As Integer
'Set Btn = ActiveSheet.Buttons(Application.Caller) ' either this
Set Btn = ActiveSheet.Shapes(Application.Caller) ' or this
With Btn.TopLeftCell
RowNumber = .Row
End With
SelectRangea RowNumber
End Sub
Automatically create the buttons
We could create a macro that creates the buttons, if they don't exist, using Sheet.Shapes.AddShape and sets the .OnAction of them to MyButton_Click:
' Copy the code below to a standard module.
' Create buttons on a sheet.
' Sht : The sheet to create buttons on
' RowNumber : Create buttons from RowNumber and down.
' ColNumber : The column the button is created in.
' ColNumberSrc: The column used to determine the number of rows.
Public Sub AddButtons(Sht As WorkSheet,
RowNumber As Integer,
ColNumber As Integer,
ColNumberSrc As Integer)
Dim MyLeft As Double
Dim MyTop As Double
Dim Rng As Range
Dim Shp As Shape
Dim NumRows As Integer
NumRows = Sht.Range.Cells(Sht.Rows.Count, ColNumberSrc).End(xlUp).Row
If NumRows < RowNumber Then Exit Sub
For Idx = RowNumber To NumRows
Set Rng = Sht.Range.Cells(Idx, ColNumber)
MyLeft = Rng.Left
MyTop = Rng.Top
' We could let the size of the button's we create be the same size as the cell.
Set Shp = Sht.Shapes.AddShape(msoShapeRectangle, MyLeft, MyTop, 100, 22)
Shp.Name = "Btn" & Sht.Index & "_" & Idx
Shp.TextFrame.Characters.Text = "Clickme"
Shp.OnAction = "MyButton_Click"
Next Idx
End Sub
Don't use buttons
We could remove the buttons and use double-click instead. This will copy the double-clicked row:
' Copy the three lines to the corresponding function in your sheet module.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim RowNumber As Integer
RowNumber = Target.Row
SelectRangea RowNumber
End Sub
Don't confuse the user
We should avoid the use of Copy and Select, as it can worsen the user experience. We should only use them when the user expects us to use them. Refactor the code to avoid using them:
' Copy the code below to a standard module
Public Sub SelectRangea(ByVal RowNumber As Integer)
Dim Sht As WorkSheet
Dim Rng As Range
Dim Dat As Variant
' Copy the row clicked
Set Sht = Sheets("Tournaments")
Set Rng = Sht.Range("B" & RowNumber & ":G" & RowNumber)
Dat = Rng
' Paste the row
Set Sht = Sheets("Results")
RowNumber = Sht.Range("A" & Sht.Rows.Count).End(xlUp).Row + 1
Set Rng = Sht.Range("B" & RowNumber & ":G" & RowNumber)
Rng = Dat
' Fix column widths
Sht.UsedRange.Columns.AutoFit
End Sub
See also
how to add a shape at a specific cell
how to get the row number of the button clicked.
how to get the row of the cell clicked
NB
I don't have access to an office environment, so I can't test the code at the moment.
I think we can set an option for a shape so it stays in it's cell when cells are resized, added or deleted.
Option Explicit
Sub LoopThroughValidationList()
Dim lst As Variant
Dim rCl As Range
Dim str As String
Dim iX As Integer
str = Range("B1").Validation.Formula1
On Error GoTo exit_proc:
If Left(str, 1) = "=" Then
str = Right(str, Len(str) - 1)
For Each rCl In Worksheets(Range(str).Parent.Name).Range(str).Cells
Range("B1").Value = rCl.Value
Next rCl
Else
lst = Split(str, ",")
For iX = 0 To UBound(lst)
Range("B1").Value = lst(iX)
Next iX
End If
Exit Sub
exit_proc:
MsgBox "No validation list ", vbCritical, "Error"
End Sub
I am tring to iterate through two data validation lists and copy a range in sheet1 to sheet2 for every iteration. This code iterates through one data validation drop down and doesn't copy the range I want in sheet1.
Change data validation list1 to first item in list
Change data validation list2 to first item in list
Copy range from sheet1 to sheet2, first item in list + first item in list + copied range
Repeat
UPDATE 2018-07-27:
Here are the formulas for my data validation list ='A. Dashboard2'!$B$1:$V$1, ='A. Dashboard'!$B$1:$V$1. And also =OFFSET('A. Dashboard'!$A$1;1;MATCH($F$4;'A. Dashboard'!$A$1:$V$1;0)-1;COUNTA(OFFSET('A. Dashboard'!$A$1;1;MATCH($F$4;'A. Dashboard'!$A$1:$V$1;0)-1;55;1));1)
Untested, written on mobile. See if it works and whether it does what you want.
Code expects that validation list 1 will always begin with an = sign and will be a reference to a range -- and that validation list 2 is a ; delimited list.
Code expects sheets called Dashboard and Result to already exist.
Code will attempt to copy the various ranges (from Dashboard sheet) to a new row on the Result sheet for each item in the validation lists.
Option Explicit
Sub LoopThroughValidationLists()
With thisworkbook
Dim resultsRange as range 'First cell to output to'
Set resultsRange = . worksheets("Result").range("A1")
with .worksheets("Dashboard")
dim list1range as range
set list1range = .range("G3")
dim list2range as range
set list2range = .range("W3")
dim rangeToCopy1 as range
set rangeToCopy1 = .range("K9:K40")
dim rangeToCopy2 as range
set rangeToCopy2 = .range("Z9:Z40")
end with
end with
dim list1formula as string
on error resume next
list1formula = list1range.Validation.Formula1
on error goto 0
dim list2formula as string
on error resume next
list2formula = list2range.Validation.Formula1
on error goto 0
if Len(list1formula) = 0 then
MsgBox("Validation list1 not detected.")
exit sub
elseif ASC(list1formula) <> 61 then
MsgBox("Expected list1 to begin with '='")
exit sub
elseif instrrev(list1formula,"!",-1,vbbinarycompare) > 0 then
List1formula = mid$(list1formula,instrrev(list1formula,"!",-1,vbbinarycompare)+1)
List1formula = replace(list1formula,"$",vbnullstring,1,vbbinarycompare)
End if
if Len(list2formula) = 0 then
MsgBox("Validation list2 not detected.")
exit sub
end if
dim list1items as range
on error resume next
set list1items = thisworkbook.worksheets("A. Dashboard").range(mid$(list1formula,2))
on error goto 0
if list1items is nothing then
MsgBox("Expected validation list1 to refer to a range:" & VBnewline & vbnewline & list1formula)
exit sub
end if
dim list2items() as string
list2items() = split(list2formula, ";")
if list1items.cells.count <> (ubound(list2items) +1) then
MsgBox ("Count of items in list1 is not the same as count of items in list2:" & vbnewline & vbnewline & "List1 = " & list1items.cells.count & " cells " & vbnewline & "List2 = " & (ubound(list2items) +1) & " items")
Exit sub
end if
dim cell as range
dim listIndex as long
application.calculation = xlCalculationManual
application.screenupdating = false
with resultsRange
for each cell in list1range
list1range.value2 = cell.value2
list2range.value2 = list2items(listindex)
list1range.parent.calculate ' Sheet needs to re-calculate '
' Column 1 = list1'
' Column 2 = list2'
' Columns 3 to 34 = K9:K40'
' Columns 35 to 66 = Z9:Z40'
.offset(listindex, 0) = cell.value2 ' Value from list1'
.offset(listindex, 1) = list2items(listindex) ' Value from list2'
rangeToCopy1.copy
'below needs to appear on a new line'
.offset(listIndex, 2).pastespecial paste:=xlPasteValuesAndNumberFormats,
transpose:=True
rangeToCopy2.copy
'below needs to appear on a new line'
.offset(listIndex, 34).pastespecial paste:=xlPasteValuesAndNumberFormats,
transpose:=True
listindex = listindex +1
next cell
application.calculation = xlautomatic
application.screenupdating = true
end with
End Sub
Part 1: A combo box in sheet1 to dynamically list unique values from a column in sheet2 put it in the drop down list
Part 2: Display the related entries of sheet2 in sheet1 based on the combo box selection.
I have done the part 1 in a method call fillCombo and have called it under ComboBox1_DropButtonClick() and part 2 under the method ComboBox1_Change()
First time when i click dropdown arrow of combo box it lists the unique entries and on making the selection in it, the related entries are displayed in sheet1 and everything is fine.
During the next selection of dropdown arrow it goes to ComboBox1_DropButtonclick() method then ComboBox1_change() method, ComboBox1_change() method without the dropdown list appearing and me selecting
So it works correctly only in the first instance.
Can you please correct the error.
Private Sub ComboBox1_Change()
Dim sht2, sht1, a As Long, X As Long, i As Long
Dim Lastrow As Long
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Sheet2")
a = sht2.Cells(Rows.Count, 1).End(xlUp).Row
X = 8
Lastrow = sht1.Range("D" & Rows.Count).End(xlUp).Row
sht1.Range("G8:J" & Lastrow).Clear
For i = 2 To a
If sht2.Cells(i, 3).Value = "Payments" Then
sht2.Cells(i, "C").Resize(1, 4).Copy sht1.Cells(X, "G")
X = X + 1
End If
Next
sht1.Select
sht1.Cells(1, 1).Select
End Sub
Private Sub ComboBox1_DropButtonClick()
Call fillCombo
End Sub
Sub fillCombo()
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Group = 3
firstTime = True
strValue = Sheet1.ComboBox1.Value
'last row
wsLR = ws2.Cells(Rows.Count, 1).End(xlUp).Row
'loop thru rows
For l = 2 To wsLR
If ws2.Cells(l, Group) <> "" And (InStr(uE, "|" & ws2.Cells(l, Group) & "|") = 0) Then
If firstTime = True Then
firstTime = False
uE = "|" & uE & ws2.Cells(l, Group) & "|"
Else
uE = uE & ws2.Cells(l, Group) & "|"
End If
End If
Next l
dropValues = Split(uE, "|")
Sheet1.ComboBox1.Clear
For Each cell In dropValues
If cell <> "" Then
Sheet1.ComboBox1.AddItem cell
End If
Next cell
Sheet1.ComboBox1.Value = strValue
End Sub
I have a tool, where I insert multiple small button in multiple column automatically (assume Column C1:C90,E1:E90,G1:G90...), based on some selection criteria. I am using the .Buttons.Add method of the Worksheet class to create the buttons.
I am unable to find correct cell address when I click on a button. E.g. If I click on button in cell C2, It gives C70 cell address, if I Click on E4 it still gives some other cell address. I tried with following code below. Can anyone help me on this?,
Sub Mainscoresheet()
' Mainlineup Macro to add button
Dim b As Object, RowNumber,ColNumber As Integer
Set b = ActiveSheet.Buttons(Application.Caller)
With b.TopLeftCell
RowNumber = .Row
ColNumber = .Col
End With
MsgBox "Row Number " & RowNumber
MsgBox "Row Number " & ColNumber
End Sub
I added below the button add function.
XRow = 7: xCol = 5
Do Until wks.Cells(XRow, 1) = ""
DoEvents
For i = 1 To M_Count
Set Bt = wks.Range(Cells(XRow, xCol), Cells(XRow, xCol))
Set btn = wks.Buttons.Add(Bt.Left + 1, Bt.Top + 1, Bt.Width - 2, Bt.Height - 2)
With btn
.OnAction = "BtnCopy"
.Caption = ">>"
.name = "Note" & Now
End With
xCol = xCol + 2
Next i
xCol = 5
XRow = XRow + 1
Loop
You are trying to identify the button that was clicked with the following line:
Set b = ActiveSheet.Buttons(Application.Caller)
Using Application.Caller in this way relies on each Button having a unique name. However, when you create the buttons you use this code:
With btn
.OnAction = "BtnCopy"
.Caption = ">>"
.name = "Note" & Now
End With
But you use the Now function to add an 'id' to the Button. Using Now means that you may create more than one button with the same name because the code will run quick enough that Now will not increment within the code. Also, if you run the code a few times e.g. create buttons in 3 columns in 3 different runs then each set of buttons may likely have the same name. This will confuse Application.Caller in that it will just return the Button that is the 'first match`.
So you should use a counter to create a unique name for each button. See the code example below that does this for sample set of 10 Buttons:
Option Explicit
Sub CallButton()
Dim btn As Object
Dim lngRow As Long, lngCol As Long
Set btn = ActiveSheet.Buttons(Application.Caller)
With btn.TopLeftCell
lngRow = .Row
lngCol = .Column
End With
MsgBox "Button name " & btn.Name
MsgBox "Row Number " & lngRow
MsgBox "Col Number " & lngCol
End Sub
Sub Make10Buttons()
Dim ws As Worksheet
Dim lng As Long
Dim rng As Range
Dim btn As Object
Set ws = ThisWorkbook.Worksheets("Sheet1")
For lng = 1 To 10
Set rng = ws.Cells(lng + 1, 2)
Set btn = ws.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
With btn
.OnAction = "CallButton"
.Caption = ">>"
.Name = "Note" & lng '<--- need a unique ID for each button
End With
Next lng
End Sub
You can adapt the sample to work with your code by using XRow and xCol to create an unique suffix to append to each of your buttons.