Now, I am trying to run my code and suddenly I am getting an error in my Worksheet activation line. Yesterday, it worked well without any problems. Until now I was not able to find the mistake. Please refer to the code below. I'd appreciate if anyone can give me a suggestion on how to run the code without getting an error.
For the below commandbutton I am getting the error when clicked.
Private Sub cmdsubmit_Click()
Dim i As Integer
Dim Submittedtask As String
Worksheets("Submittedtask").Activate 'this line i am getting error
'position cursor in the correct cell A8.
ActiveSheet.Range("A8").Select
i = 1 'set as the first ID
'validate first three controls have been entered...
If Me.txtProject.Text = Empty Then 'Firstname
MsgBox "Please enter firstname.", vbExclamation
Me.txtProject.SetFocus 'position cursor to try again
Exit Sub 'terminate here - why continue?
End If
'if all the above are false (OK) then carry on.
'check to see the next available blank row start at cell A2...
Do Until ActiveCell.Value = Empty
ActiveCell.Offset(1, 0).Select 'move down 1 row
i = i + 1 'keep a count of the ID for later use
Loop
'Populate the new data values into the 'Data' worksheet.
ActiveCell.Value = i 'Next ID number
ActiveCell.Offset(0, 2).Value = Me.txtProject.Text 'set col B
ActiveCell.Offset(0, 3).Value = Me.txtEnia.Text 'set col C
ActiveCell.Offset(0, 1).Value = Me.DTPicker1.Value
'Clear down the values ready for the next record entry...
Me.txtProject.Text = Empty
Me.txtEnia.Text = Empty
Me.cboLs.Set Focus 'positions the cursor for next record entry
End Sub
Related
I would like to be able to construct a macro that is easily able to transfer cell content from one spreadsheet to another. Let me elaborate in more detail: I currently have two spreadsheets open. See picture. The worksheet on the left works via a button macro that I made (not included in picture) and generates three different adjacent values. Thus every time I would click the button, a new output would be generated.
What I would like to be able to do is to transfer that information from the worksheet on the left to the worksheet on the right into columns G, H, and I respectively (by potentially clicking the button on the right worksheet) and then having it go to the next blank row to prepare for next round of generated values.
I'm having a bit of trouble constructing this (beginner). Could you offer some assistance?
Here is what I have so far:
Sub Button1_Click()
If Not Intersect(ActiveCell, Range("G:G")) Is Nothing Then
If ActiveCell.Offset(1, 0) <> vbNullString Then
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Workbooks("Model.xlsx").Worksheets("Optimization").Range("C100").Value
ActiveCell.Offset(0, 1).Value = Workbooks("Model.xlsx").Worksheets("Optimization").Range("D100").Value
ActiveCell.Offset(0, 2).Value = Workbooks("Model.xlsx").Worksheets("Optimization").Range("E100").Value
End If
End If
End Sub
Thanks!
This should work
Sub Button1_Click()
Const RowToTakeInformation = 100
Const ColumnToTakeInformation = 3
Const ColToWriteIn = 7
Dim WBDesired As Workbook: Set WBDesired = Workbooks("Model.xlsx")
Dim WSDesired As Worksheet: Set WSDesired = Worksheets("Optimization")
'If everything is in the same WB, I don't see a valid reason why to set it
Dim RowToInsert As Long
Dim CounterColumnsToWrite As Long
If WBDesired.Worksheets(WSDesired.Name).Cells(RowToTakeInformation, ColumnToTakeInformation).Value <> "" Then ' 1. If WBDesired.Worksheets(WSDesired.Name).Cells(RowToTakeInformation, ColumnToTakeInformation).Value <> ""
'here I'm assuming it's a table or something like it that automatically recalculates when something is inserted in between
RowToInsert = Cells(Rows.Count, ColToWriteIn).End(xlUp).Row - 1
Rows(RowToInsert).Insert Shift:=xlDown
For CounterColumnsToWrite = 0 To 2
Cells(RowToInsert, ColToWriteIn + CounterColumnsToWrite).Value = WBDesired.Worksheets(WSDesired.Name).Cells(RowToTakeInformation, ColumnToTakeInformation + CounterColumnsToWrite)
Next CounterColumnsToWrite
End If ' 1. If WBDesired.Worksheets(WSDesired.Name).Cells(RowToTakeInformation, ColumnToTakeInformation).Value <> ""
End Sub
What I am trying to do is :
loop through Column Q on Sheet "Global" starting at row 3
For every cell match value to UserForm ComboBox2 Column2, and the copy the entire row to the relevant sheet from userform2 coloum1.
loop though until last row. There could be several unique values in Column Q but will all be in the Userform2's Combobox2 columns.
I have no code as an example as I have no idea where to even begin!
This is my comboxbox, as is displays, on the backing of it each item have the below code, so a name, a code "2780" and a reference "BRREPAIRS".
.AddItem "Repairs"
ComboBox2.List(13, 1) = "2780"
ComboBox2.List(13, 2) = "BRRPEAIRS"
I need it to loop through everycell on the global sheet in column G, then match the cell value to the combobox list item from column 2. Once it has found a match it uses the code from column 1 ie "2780" to copy the entire row to the sheet matching the code in column 1.
Hopefully i have explained it a little better.
Private Sub CommandButton1_Click()
Dim findmatch As Object
Dim lastcell As Integer
Set findmatch = ThisWorkbook.Sheets("Global").Range("G:G").Find(What:=UserForm2.ComboBox2.column(1), LookIn:=xlValues)
If Not findmatch Is Nothing Then
lastcell = ThisWorkbook.Sheets(UserForm2.ComboBox2.Value).Cells(100000, 7).End(xlUp).row 'here find a way to locate last cell in sheet that has your name.. it keeps returning me 1 but other than that it works fine
ThisWorkbook.Sheets(UserForm2.ComboBox2.Value).Range(Cells(lastcell, 1), Cells(lastcell, 40)) = Range(Cells(findmatch.row, 1), Cells(findmatch.row, 40)).Value
Else
MsgBox "not found"
End If
End Sub
I have managed to get it to work with the following code below. It looks for the correct cell in the combobox. Then copies it to the correct sheet in the correct position.
The only problem is that it runs very slowley!! Can anyone suggest some way of speeding it up?
And the last question is, having error handling for if a sheet doesn't exists, it tell you to create the sheet, or even create the sheet for you??
I really appreciate all the help guys, have been bashing my head on the wall for days!!!
Dim i, lastD, lastG As Long
Dim j As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With
' find last row
lastG = sheets("Global").Cells(Rows.Count, "Q").End(xlUp).row
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
' loop over values in "details"
For j = 0 To Me.ComboBox2.ListCount - 1
currVal = Me.ComboBox2.List(j, 2)
If lookupVal = currVal Then
sheets("Global").Cells(i, "Q").EntireRow.Copy
sheets(Me.ComboBox2.List(j, 1)).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End If
Next j
Next i
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
End With
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
I need to locate a date entered by a user in a specific column. If the date is found, the macro should check the third field to the right:
if it's blank, it should copy and paste a specific value from another sheet;
if it's not blank, just pop out a message box.
The current code does not do a copy-paste and somehow it is not running through a list of dates though it has been already working before.
Sub EnterRecord()
Dim rcdDate As Date
Dim r As Range
Set ws1 = Sheets("Manual")
Set ws2 = Sheets("Data")
ws1.Activate
rcdDate = InputBox("Please enter date dd/mm/yyyy")
With ws1.Range("K:K")
Set r = .Cells.Find(What:=rcdDate)
If Not r Is Nothing Then
r.Select
ActiveCell.Offset(0, 3).Activate
If ActiveCell.Value = "" Then
ws2.Range("b1").Copy
ws1.ActiveCell.Value.Paste Paste:=xlPasteValues
End If
MsgBox "Date is incorrect or the record is already entered"
End If
End With
End Sub
If you want to search for the date in column K of ws1 and you already are using the With then replace:
Set r = Cells.Find(What:=rcdDate)
with
Set r = .Cells.Find(What:=rcdDate)
There may be other problems.
EDIT#1
Once you have executed:
ActiveCell.Offset(0, 3).Activate
you have "moved" the ActiveCell, so replace:
If ActiveCell.Offset(0, 3).Value = "" Then
with
If ActiveCell.Value = "" Then
I have an InputBox that stores user input into a variable. The input the user is inputting is a cell number.
For example, the input box pops up and asks the user, "Where would you like to start?" The user would then type in A4, or whichever cell they would want to start.
My question is, is there a way to allow the user to physically click on cell A4 instead of typing it in?
Thanks in advance for any help
Update: So, basically we have long lists of transposed data that span horizontally. We want those lists to stacked on top of each other horizontally, which is what this code is supposed to do.
Everything worked fine before, but the user would to have to manually type in the cell number into the InputBox. The input box asks the user where they want to start cutting and the second box asks the user where they want to start pasting. I would store those input values into string variables and everything worked like a charm.
Since then, I wanted the user to be able to physically click on the cell since it can be difficult to look at which row number it actually is. The code below is updated to reflect the changes trying to be used to allow the user to click on the cell. I added the Application.InputBox method and changed my declarations of the variables to Range.
I stepped into the program one at a time to see what was going on and this is what I found. Before, if the User wanted to start at B4 and paste to A16, it would select the data range for B(B4:B15), cut it, and paste it to A16. Then, the way I had the code, it would go back to the B4 user input spot and using a for loop to increment my x variable, it would offset to the next column over to the right. So, it would then repeat the process of cutting column C(C4:C15) and paste it this time to A28(using xldown), and so on for proceeding columns.
What is happening now when I stepped into this current code is that I don't see any recorded values into my Range variables. It does the first step of cutting B4:B15 and pasting it to A16, but when it goes to run the next loop, instead of starting back at B4 and offsetting, it starts off on A16 and then offsets. It should be going back to B4, which the user selected as the starting spot, and then offsetting.
Sorry, for the long explanations, but I hope this helped to clear the situation up.
Current code using Application.InputBox
Dim x As Integer
Dim strColumnStart As Range
Dim strColumnEnd As Range
On Error Resume Next
Application.DisplayAlerts = False
Set strColumnStart = Application.InputBox("What cell would you like to start at?", "Starting position","Please include column letter and cell number", Type:=8)
On Error GoTo 0
Set strColumnEnd = Application.InputBox("Where would you like to paste the cells to?", "Pasting position", "Please include column letter and cell number", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If strColumnStart = "What cell would you like to start at?" Or _
strColumnEnd = "Please include column letter and cell number" Then
Exit Sub
Else
For x = 0 To strColumnStart.CurrentRegion.Columns.Count
strColumnStart.Select
ActiveCell.Offset(0, x).Select
If ActiveCell.Value = Empty Then
GoTo Message
Else
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut strColumnEnd.Select
ActiveCell.Offset(-2, 0).Select
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
strColumnStart.Select
End If
Next x
End If
Message:
MsgBox ("Finished")
strColumnEnd.Select
ActiveSheet.Columns(ActiveCell.Column).EntireColumn.AutoFit
Application.CutCopyMode = False
End Sub
From: http://www.ozgrid.com/VBA/inputbox.htm
Sub RangeDataType()
Dim rRange As Range
On Error Resume Next
Application.DisplayAlerts = False
Set rRange = Application.InputBox(Prompt:= _
"Please select a range with your Mouse to be bolded.", _
Title:="SPECIFY RANGE", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rRange Is Nothing Then
Exit Sub
Else
rRange.Font.Bold = True
End If
End Sub
Updated with OP's requirements:
Sub Test2()
Dim x As Integer
Dim rngColumnStart As Range
Dim rngColumnEnd As Range
Dim rngCopy As Range
Dim numRows As Long, numCols As Long
On Error Resume Next
Set rngColumnStart = Application.InputBox( _
"Select the cell you'd like to start at", _
"Select starting position", , Type:=8)
If rngColumnStart Is Nothing Then Exit Sub
Set rngColumnEnd = Application.InputBox( _
"Select where you'd like to paste the cells to", _
"Select Pasting position", , Type:=8)
On Error GoTo 0
If rngColumnEnd Is Nothing Then Exit Sub
Set rngColumnEnd = rngColumnEnd.Cells(1) 'in case >1 cell was selected
Set rngCopy = rngColumnStart.CurrentRegion
numRows = rngCopy.Rows.Count
numCols = rngCopy.Columns.Count
For x = 1 To numCols
rngCopy.Columns(x).Copy _
rngColumnEnd.Offset((x - 1) * numRows, 0)
Next x
rngCopy.ClearContents
MsgBox ("Finished")
rngColumnEnd.EntireColumn.AutoFit
Application.CutCopyMode = False
End Sub