im trying to create a button for my listbox to go to the next empty cell un column B. when i use this code it goes to the last empty cell in column A. please help. thanks
Private Sub CommandButton6_Click()
Dim i As Long
With lstOCC
For i = .ListCount - 1 To 0 Step -1
Debug.Print i, lstOCC.List(i, 0)
If lstOCC.Column(i, 0) <> "" Then
.ListIndex = i
Exit For
End If
Next i
End With
End Sub
Related
I have a VBA code that removes empty cells, allowing for data further down in the column to move up to the top. There are two things that I am looking to fix. One, I don't want to exit the sub, I want to exit the if statement. I've read that you can exit loops, whiles, fors, etc. But not ifs. I don't want to exit the sub because I have more code in my sub. Any suggestions?
I am also having issues adding another line in the code to run if there is already data at the top of the column.
Sub Remove_Empties ()
Dim Last as Long
Dim Mcol as Range
Last = Cells(Rows.Count, "AD").End(xlUp).Row
If Last = 1 Then Exit Sub 'no value only header in row 1
'otherwise
Set Mcol = Range("AD2:AD" & Last) 'contains any value
Application.ScreenUpdating = True
Mcol.SpecialCells(xlCellTypeBlanks).Delete xlUp
Application.ScreenUpdating = True
End Sub
I want it to be able to run the following three scenarios. The first contains data in the row below the header. The second has a couple of empty cells. The third has all empty cells. 1 should not change, 2 should change to match 1's format, and 3 should do nothing. 2 and 3 can be done with the code above, but not 1.
1 2 3
A
B
C A
D B
C
D
Perhaps something like this, noting the following:
You don't need two Application.ScreenUpdating = True lines. You can probably get rid of both.
You need to handle the possibility of no blank cells (column 1).
Sub Remove_Empties()
Dim Last As Long
Last = Cells(Rows.Count, "AD").End(xlUp).Row
If Last <> 1 Then
Dim Mcol As Range
Set Mcol = Range("AD2:AD" & Last) 'contains any value
Dim cellsToDelete As Range
On Error Resume Next
Set cellsToDelete = Mcol.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not cellsToDelete Is Nothing Then
cellsToDelete.Delete shift:=xlUp
End If
End If
End Sub
Or slightly condensed:
Sub Remove_Empties()
Dim Last As Long
Last = Cells(Rows.Count, "AD").End(xlUp).Row
If Last <> 1 Then
On Error Resume Next
Range("AD2:AD" & Last).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0
End If
End Sub
I will just add another answer that you can possibly use in your logic (code) moving forward. Using a simple GoTo statement will break out of an If. For example:
Sub UsingGoTo()
If Last = 1 Then
'do something
GoTo CheckComplete
Else
'if not maybe exit sub?
Exit Sub
End If
CheckComplete:
'continue with program
End Sub
I am going to use listbox to allow users to multiselect. However, I have no idea to put them items selected into each cell in a column. Here are my codes. I get stuck in the For statement as I know that it run go through the inner loop and then the outer loop. Anyone can help...Thanks
Private Sub lbaspectc_AfterUpdate()
For Each selected In Me.listbox.ItemsSelected
For Each c3 In Worksheets("maintenance").Range(Cells(2, 7), Cells(, 7)) 'Here i would like to start filling in from cell G2. I am not sure if the syntax is correct'
c3.Value = selected.Value
Next
Next
End Sub
Do you mean like this? You'll need to re-assign to the correct control.
Private Sub CommandButton1_Click()
Dim i As Long, j As Long
j = 2
With Me.ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then
Worksheets("maintenance").Cells(j, 7).Value = .List(i)
j = j + 1
End If
Next i
End With
End Sub
I have a sheet and the user input Starts in A7 and calculations are inserted with a macro to B7 all the way through I.
I got all that worked out but what i need is: the user is going down typing in data in Column A, lets say they input data Starting from A7, through A11, then skip A12 and type into A13, i want the sheet to automatically move the user's input into A12 so there's never any blank rows IN BETWEEN the data in column A.
Ideally all the data should be in sequence and there shouldn't be any blank rows in between the data entered in column A.
Here is the code i have come up with thus far:
Private Sub worksheet_change(ByVal Target As Range)
Dim r As Integer
Dim c As Integer
1 If Not Intersect(Target, Range("A:C")) Is Nothing Then
If Target.Row >= Range("FormulaRange").Row + 1 Then
If Target.Row <= Range("RowTracker").Value + 1 Then
Dim t
RWS = Target.rows.Count
COLS = Target.Columns.Count
For r = 1 To RWS
For c = 1 To COLS
If Not IsNumeric(Target.rows.Cells(r, c).Value) Then
'Else
MsgBox "Please enter only numeric values."
Application.Undo
'End
Else
If Target.rows.Cells(r, 2) = "" Then Target.rows.Cells(r, 2) = 0
If Target.rows.Cells(r, 3) = "" Then Target.rows.Cells(r, 3) = 0
End If
Next c
Next r
Else
MsgBox "Please enter data in the next available line."
Exit Sub
End If
End If
End If
End Sub
Right now it detects if i skip rows and input arbitrarily in A giving me a warning not to do so but i would love it just took my input and put it back into the next available row in column A.
I thought about doing a Row.Delete but the way the code is set up is keeps detecting the deleted row as skipping cells in A column continuously giving me the error of "Please Enter Data in the next available line."
Key point missing is to prevent a cascade of events as you change the sheet. Use Application.EnableEvent = False to prevent this.
Then deleting rows with blanks will work, something like this
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rw As Long
Dim i As Long, j As Long
On Error GoTo EH
If Not Application.Intersect(Target, Me.Columns("A:C")) Is Nothing Then
rw = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row
' Prevent a cascade of events
Application.EnableEvents = False
For i = rw To 1 Step -1
'Check for blanks in column A, delete row if found
If IsEmpty(Me.Cells(i, 1)) Then
Me.Rows(i).Delete
End If
'check for non numeric data
For j = 1 To 3
If Not IsNumeric(Me.Cells(i, j)) Then
Me.Cells(i, j).ClearContents
End If
'Enter Zeros's
If j > 1 Then
If IsEmpty(Me.Cells(i, j)) Then
Me.Cells(i, j) = 0
End If
End If
Next
Next
End If
EH:
' restore event handling
Application.EnableEvents = True
End Sub
Notes:
The delete rows and check for non numeric/blanks will interact, possibly in ways you don't expect
If user leaves column A blank and enters data into other columns, it will be deleted
I've left out the Named Range checks, as I'm unsure what they are doing. You can reinstate to suit.
Might be better to validate and warn the user before deleting
Something like this will force the user to only stay in the next possible row for column A without being able to enter more information.
This isn't foolproof, but will get you started. You can extend as needed:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And Target.Row <> 1 Then
If Len(Target.Offset(-1)) = 0 Then
Target.Offset(-1).Select
End If
End If
End Sub
I am looking to use a macro to add the value of a certain cell in a worksheet to a table in another worksheet each time each time a button is pressed. For example, the first time the button is pressed I want the value of cell A1 in worksheet2 to be equal to cell C3 in worksheet1, next time B1 in worksheet2 is equal to C3 in worksheet1 , and so on. The macro should only add a value to the table if the cell thst it's being added to is empty.
This is what I have so far:
Sub Button32_ClickandUpdate
myVariable = Worksheets("Worksheet1").Range("C3")
For i = 1 To 6
If IsEmpty(Cells(1, i)) Then
Worksheets("Worksheet2").Range(Cells(1,i)) = myVariable
Exit Sub
End If
Next i
End Sub
Any help would be greatly appreciated.
Try the code below, to update one cell at a time (when cell is empty)
Sub Button32_ClickandUpdate()
For i = 1 To 6
If IsEmpty(Sheets("Worksheet2").Cells(1, i).Value) Then
Sheets("Worksheet2").Cells(1, i).Value = Sheets("Worksheet1").Range("C3").Value
Exit Sub
End If
Next i
End Sub
Comment: you can use this also without the .Value
Try this:
Sub Button32_ClickandUpdate
myVariable = Worksheets("Worksheet1").Range("C3")
For i = 1 To 6
If IsEmpty(Worksheets("Worksheet2").Cells(1, i)) Then
Worksheets("Worksheet2").Cells(1, i) = myVariable
'Exit Sub (remove or comment this line to update all cells at the sime time)
End If
Next i
End Sub
Edit
According to new description given:
Sub Button32_ClickandUpdate
myVariable = Worksheets("Worksheet1").Range("C3")
i = 1
While i < 7
If IsEmpty(Worksheets("Worksheet2").Cells(1, i)) Then
Worksheets("Worksheet2").Cells(1, i) = myVariable
End If
i = i + 1
Wend
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