I am trying to create a sheet which will have a checkbox in each non-empty line. To automatically adjust the number of checkboxes I created this macro:
Sub checkboxes()
Dim i As Integer
For i = 9 To 200
Set CurCell = ActiveSheet.Cells(i, 3)
If CurCell.Value > 1 Then
ActiveSheet.Shapes("CheckBox" & CStr(i)).Visible = True
Else
ActiveSheet.Shapes("CheckBox" & CStr(i)).Visible = False
End If
Next i
End Sub
I expect number of potential rows with data not greater than 200. Macro checks if value in column C for each line is >1, if true checkbox is visible, else it's hidden.
My problem is that I don't know how to put the loop counter "i" into Shape name - I got an error using code above. Can someone help?
I think this would be a more elegant solution.
This loops through all shapes on ActiveSheet and checks if they are a msoOLEControlObject (see here for more information on that matter).
Sub checkboxes()
Dim curCellValue as Variant
Dim i As Long
For i = 1 To ActiveSheet.Shapes.Count
If ActiveSheet.Shapes(i).Type = msoOLEControlObject Then
curCellValue = ActiveSheet.Cells(i, 3).Value
If curCellValue <> "" Then
ActiveSheet.Shapes(i).Visible = True
Else
ActiveSheet.Shapes(i).Visible = False
End If
End If
Next i
End Sub
So why is this "better"?
You don't have to "guess" how many values there will be.
If you ever change a name of a CheckBox this script will still be working.
This checks for empty cells.
Also note that I replaced Set CurCell = ActiveSheet.Cells(i, 3) with curCellValue = ActiveSheet.Cells(i, 3).Value. You don't need to Set an object in every iteration. Filling the variable suffices.
But: this will check for all msoOLEControlObjects which includes checkboxes, textboxes and the like.
HTH.
Related
I'm currently working on a code that hides empty cells ,but the problem is i want it to start hiding at a certain range ("A9:A12") not at the beginning of the sheet.
here is my program :
Sub EmptyRow()
'Dim s As String
po = Range("A9:A12").Count
Range("A8").Activate
For i = 1 To po
s = i & ":" & i
If IsEmpty(Cells(i, 1).Value) Then
Rows(s).Select
Selection.EntireRow.Hidden = True
End If
Next
End Sub
The program keeps on hiding cells from the beginning, how do I set it up so it deletes from the range i want it to. Please help.
You can even make your code shorter like this:
For i = 9 To 12
Cells(i, 1).EntireRow.Hidden = IsEmpty(Cells(i, 1).Value)
Next i
Thus, the result of the Hidden property would be dependent on whether the Cells(i,1) is empty. It is easier to understand and to maintain.
Check the solution below. In case you need to change your affected area, just change the value of targetRange.
Sub EmptyRow()
Dim targetRange as Range, po as Long, i as Long
Set targetRange = Range("A9:A12")
po = targetRange.Count
With targetRange
For i = 1 To po
If IsEmpty(.Cells(i, 1).Value) Then
.Rows(i).EntireRow.Hidden = True
End If
Next
End With
End Sub
Sheets("Sheet1").Range("A9:A12").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
SpecialCells results in run-time error if no cells are found, but that can be checked:
If [CountBlank(Sheet1!A9:A12)] Then _
[Sheet1!A9:A12].SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
or ignored:
On Error Resume Next
[Sheet1!A9:A12].SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
You can get rid of bits like select
Sub EmptyRow()
For i = 9 To 12
If IsEmpty(Cells(i, 1).Value) Then
Cells(i, 1).EntireRow.Hidden = True
End If
Next i
End Sub
I have this practice file with 5 order prices. The goal is to add $20 to each of the record and have a message box to display the result.
Here is the data:
My code is this:
Sub TotalDelivery()
Dim curDelCharge As Currency
Dim curTotal(4)
Dim i As Integer
Worksheets("Sheet1").Range("B10").Activate
Const curDelCharge = 20
For i = 0 To 4
curTotal(i) = ActiveCell.Offset(i, 1).Value + curDelCharge
MsgBox (curTotal(i))
Next i
End Sub
However the message box only displays 20 which is only my curDelCharge value.
To debug, I change the msgbox code into:
MsgBox (ActiveCell.Offset(i, 1).Value)
The return value is blank which means the code doesn't read my ActiveCell value. Why is that?
Thanks in advance!
This line:
curTotal(i) = ActiveCell.Offset(i, 1).Value + curDelCharge
should instead be:
curTotal(i) = ActiveCell.Offset(i, 0).Value + curDelCharge
Putting a "1" will move the offset 1 column to the right, which you don't want.
Sub TotalDelivery()
Dim curTotal(4)
Dim i As Integer
Dim rngCellsToChange As Range 'range of cells you are targeting
Dim rCell As Range 'individual cell in collection of cells. See alternative solution below
'You can refer to cells directly, without activating them.
'You are highly discouraged to use Activate or Select methods.
'Use ThisWorkbook to explicitly tell VBA, which workbook you are targeting
Set rngCellsToChange = ThisWorkbook.Worksheets("Sheet1").Range("B10:B14")
Const curDelCharge = 20
For i = 0 To 4
curTotal(i) = rngCellsToChange(i + 1).Value + curDelCharge
MsgBox (curTotal(i))
Next i
'Alternatively, you can use the Range object to loop through all it's cells, like so:
For Each rCell In rngCellsToChange
MsgBox rCell.Value + curDelCharge
Next
End Sub
I'm looking for a way to highlight cells in sheet1 if they match the value in sheet2. Here is the code I have, there aren't any errors coming up but it does nothing. Basically I thought a Do while loop to go through all the records until it hit a blank and then it would read the cell value selected by my offset and compare it to the next sheets cell value while staying on the same row, and if it matched it would highlight on sheet 1 but if it didn't it would move on. Let me know how much I'm off here as I don't have much VBA knowledge. Thanks.
Public Sub RoundedRectangle1_Click()
Dim resource As Range
Dim register As Range
Dim cancel As Range
Set resource = Worksheets("Resource List1").Cells(2, 4)
Set register = Worksheets("Registered List").Cells(2, 1)
Set cancel = Worksheets("Cancelled List").Cells(2, 1)
Call findRegister(resource, register)
End Sub
Public Sub findRegister(ByRef resource As Range, ByRef register As Range)
Dim i As Integer
i = 0
Do While resource.Offset(i, 3) <> ""
If resource.Offset(i, 3).Value = register.Range("A2").Value Then
resource.Offset(i, 3).Cells.Interior.ColorIndex = 37
End If
i = i + 1
Loop
End Sub
Your code is essentially correct, but I think you're having trouble with referencing the right cells. A good debugging technique would be to add .Cells.Interior.ColorIndex = 4 or something similar in your code to see visually whether you're referencing the proper cells. You can also put "F5", "F8", and breakpoints to good use in figuring out what's wrong. See http://www.excel-easy.com/vba/examples/debugging.html if you've never used these.
For example:
Do While resource.Offset(i, 3) <> "" '<--Insert a breakpoint on this line,
'then press "F8" to make sure the
'code inside your Do While loop is
'being executed
resource.Offset(i, 3).Cells.Interior.ColorIndex = 4
register.Range("A2").Cells.Interior.ColorIndex = 6
If resource.Offset(i, 3).Value = register.Range("A2").Value Then
resource.Offset(i, 3).Cells.Interior.ColorIndex = 40
End If
i = i + 1
Loop
Maybe something as simple as this . . . .
Sub Compare2Shts()
For Each Cell In Worksheets("CompareSheet#1").UsedRange
If Cell.Value <> Worksheets("CompareSheet#2").Range(Cell.Address) Then
Cell.Interior.ColorIndex = 3
End If
Next
For Each Cell In Worksheets("CompareSheet#2").UsedRange
If Cell.Value <> Worksheets("CompareSheet#1").Range(Cell.Address) Then
Cell.Interior.ColorIndex = 3
End If
Next
End Sub
Can anyone walk me through how to write a script to delete the entire row if a cell in column D = "" on sheet 3 in range D13:D40.
Also, how to prevent the user from accidentally running the script again once those cells in the range are already deleted and other cells are now on the D13:D40 range?
Solution: This is working for me:
Sub DeleteRowsWithEmptyColumnDCell()
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.ActiveSheet.Range("D13:D40")
With rng
' Loop through all cells of the range
' Loop backwards, hence the "Step -1"
For i = .Rows.Count To 1 Step -1
If .Item(i) = "" Then
' Since cell is empty, delete the whole row
.Item(i).EntireRow.Delete
End If
Next i
End With
End Sub
Explanation: Run a for loop through all cells in your Range in column D and delete the entire row if the cell value is empty. Important: When looping through rows and deleting some of them based on their content, you need to loop backwards, not forward. If you go forward and you delete a row, all subsequent rows get a different row number (-1). And if you have two empty cells next to each other, only the row of the first one will be deleted because the second one is moved one row up but the loop will continue at the next line.
No need for loops:
Sub SO()
Static alreadyRan As Integer
restart:
If Not CBool(alreadyRan) Then
With Sheets("Sheet3")
With .Range("D13:D40")
.AutoFilter 1, "="
With .SpecialCells(xlCellTypeVisible)
If .Areas.Count > 1 Then
.EntireRow.Delete
alreadyRan = alreadyRan + 1
End If
End With
End With
.AutoFilterMode = False
End With
Else
If MsgBox("procedure has already been run, do you wish to continue anyway?", vbYesNo) = vbYes Then
alreadyRan = 0
GoTo restart:
End If
End If
End Sub
Use AutoFilter to find blank cells, and then use SpecialCells to remove the results. Uses a Static variable to keep track of when the procedure has been run.
Here's my take on it. See the comments in the code for what happens along the way.
Sub deleterow()
' First declare the variables you are going to use in the sub
Dim i As Long, safety_net As Long
' Loop through the row-numbers you want to change.
For i = 13 To 40 Step 1
' While the value in the cell we are currently examining = "", we delete the row we are on
' To avoid an infinite loop, we add a "safety-net", to ensure that we never loop more than 100 times
While Worksheets("Sheet3").Range("D" & CStr(i)).Value = "" And safety_net < 100
' Delete the row of the current cell we are examining
Worksheets("Sheet3").Range("D" & CStr(i)).EntireRow.Delete
' Increase the loop-counter
safety_net = safety_net + 1
Wend
' Reset the loop-counter
safety_net = 0
' Move back to the top of the loop, incrementing i by the value specified in step. Default value is 1.
Next i
End Sub
To prevent a user from running the code by accident, I'd probably just add Option Private Module at the top of the module, and password-protect the VBA-project, but then again it's not that easy to run it by accident in the first place.
This code executes via a button on the sheet that, once run, removes the button from the worksheet so it cannot be run again.
Sub DeleteBlanks()
Dim rw As Integer, buttonID As String
buttonID = Application.Caller
For rw = 40 To 13 Step -1
If Range("D" & rw) = "" Then
Range("D" & rw).EntireRow.Delete
End If
Next rw
ActiveSheet.Buttons(buttonID).Delete
End Sub
You'll need to add a button to your spreadsheet and assign the macro to it.
There is no need for loops or filters to find the blank cells in the specified Range. The Range.SpecialCells property can be used to find any blank cells in the Range coupled with the Range.EntireRow property to delete these. To preserve the run state, the code adds a Comment to the first cell in the range. This will preserve the run state even if the Workbook is closed (assuming that it has been saved).
Sub DeleteEmpty()
Dim ws As Excel.Worksheet
Set ws = ActiveSheet ' change this as is appropriate
Dim sourceRange As Excel.Range
Set sourceRange = ws.Range("d13:d40")
Dim cmnt As Excel.Comment
Set cmnt = sourceRange.Cells(1, 1).Comment
If Not cmnt Is Nothing Then
If cmnt.Text = "Deleted" Then
If MsgBox("Do you wish to continue with delete?", vbYesNo, "Already deleted!") = vbNo Then
Exit Sub
End If
End If
End If
Dim deletedThese As Excel.Range
On Error Resume Next
' the next line will throw an error if no blanks cells found
' hence the 'Resume Next'
Set deletedThese = sourceRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not deletedThese Is Nothing Then
deletedThese.EntireRow.Delete
End If
' for preserving run state
If cmnt Is Nothing Then Set cmnt = sourceRange.Cells(1, 1).AddComment
cmnt.Text "Deleted"
cmnt.Visible = False
End Sub
I've recently had to write something similar to this. I'm not sure that the code below is terribly professional, as it involves storing a value in cell J1 (obviously this can be changed), but it will do the job you require. I hope this helps:
Sub ColD()
Dim irow As long
Dim strCol As String
Sheets("sheet2").Activate
If Cells(1, 10) = "" Then
lrun = " Yesterday."
Else: lrun = Cells(1, 10)
End If
MsgBox "This script was last run: " & lrun & " Are you sure you wish to continue?", vbYesNo
If vbYes Then
For irow = 40 To 13 step -1
strCol = Cells(irow, 4).Value
If strCol = "" Then
Cells(irow, 4).EntireRow.Delete
End If
Next
lrun = Now()
Cells(1, 10) = lrun
Else: Exit Sub
End If
End Sub
Here is the code below:
Public n as Long ' <--above sub procedure
With Sheets("Sheet1").Range("A6").Offset(n, 0)
If n = 0 Then
.Value = 1
Else
.Value = .Parent.Range(.Address).Offset(-1, 0) + 1
End If
n = n + 1
End With
(See pic below) If I delete 4 then click command button again it just reset back to 1. I want to make it static so even I deleted the last value of row it still continue increment from the last value.
Store number
1
2
3
4
Try this:
Sub Test()
Dim trow As Long
With Sheets("Sheet1") '~~> change to suit
trow = .Range("A:A").Find(vbNullString, [A5]).Row
With .Range("A" & trow)
If trow = 6 Then .Value = 1 _
Else .Value = .Offset(-1, 0).Value + 1
End With
End With
End Sub
Above code finds the first blank cells. If it is A6 it assigns a value of 1.
Otherwise it assigns previous cell value plus 1. Is this what you're trying?
Edit1: Explanation
trow = .Range("A:A").Find(vbNullString, [A5]).Row
This finds the first empty row in Column A starting A5.
[A5] is used to return Range("A5") object. So it can also be written as:
trow = .Range("A:A").Find(vbNullString, .Range("A5")).Row
We used a VBA vbNullString constant as What argument in Range Object Find Method.
Find Method returns a Range Object so above can be written also like this:
Sub Test()
Dim r As Range
With Sheets("Sheet1") '~~> change to suit
Set r = .Range("A:A").Find(vbNullString, [A5])
With r
If .Row = 6 Then .Value = 1 _
Else .Value = .Offset(-1, 0).Value + 1
End With
End With
End Sub
What your asking for, a button with memory doesn't sound neatly solvable using just VBA.
You could potentially have a list on a hidden sheet that gets a value added to it each time the commandButton is pressed and it writes the max of the list values back to the target cell?
Alternatively you could investigate using a scrollbar from the form control section of the developer tab with a link to your target cell. I often use this technique for interactive sheets.
Named Range Method
Public sub btnPress
dim val as long
val = Range("PreviousCellValue")
set Range("PreviousCellValue") = val+1
Sheets("Sheet1").Range("A6").Offset(n, 0).value = Range("PreviousCellValue")
End sub btnPress