I have just started learning VBA (and coding in general) and I am faced with a problem to which I have not yet found a solution. I'd like to create an input box with a loop so that the output from the input box will be printed to separate cell. For example, I would like to write number "5" to the input box and the output will be printed to Cell "A1" and the next input, say number "9", will be printed to Cell "A2".
So far, I have managed to this and everything works fine except the last row as I don't know how to continue from here.
Private Sub CommandButton1_Click()
Dim myValue As Variant
myValue = InputBox("Please insert number")
Range("A1").Select
ActiveCell.Value = myValue
Range(ActiveCell) = Range(ActiveCell) + 1
End Sub
All help is appreciated
Try with below code
Private Sub CommandButton1_Click()
Dim myValue As Variant
myValue = InputBox("Please insert number")
Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = myValue
End Sub
EDIT #1:
Updated the code as per the advice of user3598756
Private Sub CommandButton1_Click()
Dim myValue As Variant
myValue = InputBox("Please insert number")
If Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Value = "" Then
Range("A" & Range("A" & Rows.Count).End(xlUp).Row) = myValue
Else
Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = myValue
End If
End Sub
edited to
shorten the code
add solution should cell "A1" be already filled with header
the following code will do:
Sub CommandButton1_Click()
With Cells(Rows.Count, 1).End(xlUp)
.Offset(IIf(.Value <> "", 1, 0)) = InputBox("Please insert number")
End With
End Sub
where the "conditional" offset is necessary to manage the first empty cell being in row 1 (no offset) or lower (1 row offset)
should cell "A1" be already filled with header, the code shortens down to:
Sub CommandButton1_Click()
Cells(Rows.Count, 1).End(xlUp).Offset(1) = InputBox("Please insert number")
End Sub
If you want to do a loop - for example 10 times - then you can use this example code:
Sub CommandButton1_Click()
Dim counter As Integer
Dim myValue As Variant
For counter = 1 To 10
myValue = InputBox("Please insert number")
Sheets("Sheet1").Cells(counter, 1).Value = myValue
Next counter
End Sub
Related
please could someone help me. I have been trying and could not seems to resolve this.
I want to compare the date in Column J to the current week. My code also include finding the last row and automatically loop until the last row.
I currently trying with the following code but having issue with
Recievedate = Format(Cells(i, "J").Value, "ww-yyyy")
I have tried
Recievedate = Format(Range(i, "J").Value, "ww-yyyy")
which was found in another post but it doesn't work. Can someone tell me what have I done wrong please? Please ignore the code after MsgBox "OK" as I am trying to build this step by step. Thank you.
Sub macro1()
Range("A1").Select
Range("A" & Rows.Count).End(xlUp).Select ' Find last row in column A and remember the active cell
Dim i As Integer
Dim Recievedate As Date
For i = 2 To ActiveCell.Row 'start from row 2 and automatically +1 until it reach the active cell
Recievedate = Format(Cells(i, "J").Value, "ww-yyyy")
If Recievedate = Format(Date, "ww-yyyy") Then
MsgBox "OK"
End If
Next i
...
Try
Sub macro1()
Range("A1").Select
Range("A" & Rows.Count).End(xlUp).Select ' Find last row in column A and remember the active cell
Dim i As Integer
' Dim Recievedate As Date
Dim Recievedate As string
For i = 2 To ActiveCell.Row 'start from row 2 and automatically +1 until it reach the active cell
Recievedate = Format(Cells(i, "J").Value, "ww-yyyy")
If Recievedate = Format(Date, "ww-yyyy") Then
MsgBox "OK"
End If
Next i
With this statement Recievedate = Format(Cells(i, "J").Value, "ww-yyyy") you assign a string to Recievedate which cannot work in case Recievedate is declared as date.
Another approach could be to use WorksheetFunction.WeekNum instead.
A possible solution - note, no Selecting required.
Sub Test()
Dim lRow As Long
lRow = Range("A" & Rows.Count).End(xlUp).Row
Dim i As Long
Dim ReceivedDate As Date
For i = 2 To lRow
ReceivedDate = Cells(i, "J")
If Format(ReceivedDate, "ww-yyyy") = Format(Date, "ww-yyyy") Then
MsgBox "Row " & i & " is ok.", vbOKOnly + vbInformation
End If
Next i
End Sub
I suggest you look for a date that is between the start and end dates of the current week.
For example (assuming your week starts on Sunday and ends on the subsequent Saturday)
Sub CurrentWeek()
Dim dt As Date
Dim dtBOW As Date, dtEOW As Date
Dim c As Range, r As Range
dtBOW = Date - Weekday(Date - 1) 'Beginning of week
dtEOW = Date + 7 - Weekday(Date) 'End of week
Set r = ThisWorkbook.Worksheets("Sheet2").Columns(10) 'Column J, fully qualified
For Each c In r.Cells
If c >= dtBOW And c <= dtEOW Then
MsgBox "found it at " & c.Address
c.Select 'Selected only so as to highlight it on the worksheet
Exit Sub
End If
Next c
MsgBox "no luck"
End Sub
Trying to create an inputbox that a user can type notes into, those notes will be input onto the same document and simultaneously create a macro enables “thumbs up icon” that will hold a macro that other members can “thumbs up” ideas they want to promote. The code below is causing the button to duplicate itself on the same cell. I need it to instead apply to the next available cell.
Sub VBA_Input_Idea_inputbox()
Dim MyInp As String
Dim NextRow As Long
MyInp = VBA.Interaction.InputBox("Please input idea", "LEARNING
REQUEST")
If MyInp = "" Then Exit Sub
NextRow = Cells(Rows.Count, 3).End(xlUp).Row + 1
Range("C" & NextRow).Value =
Excel.WorksheetFunction.Proper(MyInp)
Range("A" & NextRow).Select
ActiveSheet.Buttons.Add(0.75, 145.5, 42, 24.75).Select
Selection.OnAction = "Addcount"
End Sub
Something like this:
Sub VBA_Input_Idea_inputbox()
Dim MyInp As String
Dim NextRow As Range, btn
MyInp = VBA.Interaction.InputBox("Please input idea", "LEARNING REQUEST ")
If MyInp = "" Then Exit Sub
With ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow
.Cells(3).Value = Application.Proper(MyInp)
Set btn = ActiveSheet.Buttons.Add(.Cells(1).Left, .Cells(1).Top, _
.Cells(1).Width, .Cells(1).Height)
btn.OnAction = "Addcount"
End With
End Sub
*EDIT
Here is what ended up kind of working. The solutions below do not run the AddProj when new row is inserted.
Sub Worksheet_Calculate()
Dim X As Range
Set X = LastCell 'The X is superflous, you could just use the LastCell variable
If Sheet5.Range("A" & Rows.Count).Value < X.Value Then
X.Value = Me.Range("A" & Rows.Count).Value
AddProj
End If
End Sub
Module 1 contains the following:
Function LastCell() As Range
With Sheet5
Set LastCell = .Cells(Rows.Count, 1).End(xlUp)
End With
End Function
Sub AddProj()
Sheet1.Range("Master").Copy Sheet1.Range("C" & Rows.Count).End(xlUp).Offset(1)
End Sub
I am trying to read the data in the last cell of a column.
The value of "X" should be the value of this last cell.
I then want "X" to be compared to the number of rows and if the number of rows is less than "X", perform my macro "AddProj".
Once "X" and Column A are the same value, nothing else is to be done.
For some reason, it is not working.
This code is on the worksheet where I want the comparison to be made.
Please see my code below:
Private Sub Worksheet_Calculate()
X = LastCell
If Sheet5.Range("A" & Rows.Count).Value < Sheet5.Range("X").Value Then
Sheet5.Range("X").Value = Me.Range("A" & Rows.Count).Value
AddProj
End If
End Sub
Sub LastCell()
Range("A1").End(xlDown).Select
End Sub
The "AddProj" is a module that is referenced in the code above (thank you #jsheeran #SJR ACyril for help):
Sub AddProj()
Sheet1.Range("Master").Copy Sheet1.Range("C" & Rows.Count).End(xlUp).Offset(1)
End Sub
Thanks in advance.
Try this:
Sub Worksheet_Calculate()
Dim lRow As Long
lRow = Sheet5.Cells(Sheet5.Rows.Count, 1).End(xlUp).Row
If Sheet5.Cells(lRow, 1) > lRow Then
Sheet5.Cells(lRow, 1) = lRow
AddProj
End If
End Sub
X is a variable but you refer to it as "X". Also avoid using .Select as it is not necessary and even in this case just does nothing, because first of all a Sub cannot return a value and second .Select has also no return value. The best way to calculate the last row is this: Sheet5.Cells(Sheet5.Rows.Count, 1).End(xlUp).Row
Here is just a slight variation on UPGs great answer.
Dim lRow As Long
lRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
If lRow >= Sheet1.Cells(lRow, 1) Then
Exit Sub
Else: AddProj
End If
Hi there,
Thanks to you for your support I got recently. I am working with a excel sheet (image is attached here), here I have approx 60k rows repeating same date in column A. Actually what I need to do is to select start date & end date through user form (can see in image). when will click on OK button rest rows having dates out of given date range should be deleted.
but my code is not working exactly as I want & deleting some of rows which is within the range. I accept there may be my mistakes but after so many efforts I couldn't find out. And also dates in combo box is repeating so many times & not sorted. pls go thorough my codes below -
Private Sub CancelButton_Click()
Unload UserForm1
End Sub
Private Sub ComboBox1_Change()
ComboBox1.Value = Format(ComboBox1.Value, "dd-mmm-yyyy")
End Sub
Private Sub ComboBox2_Change()
ComboBox2.Value = Format(ComboBox2.Value, "dd-mmm-yyyy")
End Sub
Private Sub okButton_Click()
Dim i As Double, dt1 As String, dtt1 As String
Dim dt2 As String, dtt2 As String
Dim ws As Worksheet, lRow As Long
Set ws = ActiveWorkbook.Sheets(1)
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
dt1 = ComboBox1.Value
dtt1 = CDate(dt1)
dt2 = ComboBox2.Value
dtt2 = CDate(dt2)
Application.ScreenUpdating = False
For i = 2 To lRow
If Range("A" & i).Value >= dtt1 And Range("A" & i).Value <= dtt2 Then
Rows(i).Select
Selection.Delete
i = i - 1
End If
Next
Application.ScreenUpdating = True
Unload UserForm1
End Sub
Private Sub UserForm_Initialize()
Set ws = ActiveWorkbook.Sheets(1)
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
ComboBox1.RowSource = "A2:A" & lRow
ComboBox2.RowSource = "A2:A" & lRow
End Sub
Thanks a lot in advance.
Instead of
For i = 2 To lRow
try
For i = lRow To 2 step -1
Please note: I didn't check the rest of your code because probably this is the problem; when you want to delete rows (or columns) on a spreadsheet by VBA, is always a good procedure doing it from bottom to top (or right to left if you're dealing with columns).
I'm pretty new at VBA so I'm sure I'm missing something easy... I am getting a compile error "Loop without Do"
The function being called GrabDataFromMinutes I have tested successfully on it's own. Any help is appreciated, Thanks!
Public Sub CopyAllData()
Dim Location As String
Location = ActiveCell.Address
Dim CellValue As String
CellValue = ActiveCell.Value
Do
If IsEmpty(CellValue) = True Then 'If cell is empty skip row'
ActiveCell.Offset(rowOffset:=1, ColumnOffset:=-1).Activate
Loop
If Location <> "C350" Then 'run the command unless EOF'
Application.Run ("GrabDataFromMinutes")
MsgBox "I got here"
Location = ActiveCell.Address
Loop
End If
Exit Do
End Sub
As rightly mentioned by Scott you need to place the LOOP statement in the respective place. Click Here
Your code should be like this
Public Sub CopyAllData()
Dim Location As String
Location = ActiveCell.Address
Dim CellValue As String
CellValue = ActiveCell.Value
Do
If IsEmpty(CellValue) = True Then 'If cell is empty skip row'
ActiveCell.Offset(rowOffset:=1, ColumnOffset:=-1).Activate
If Location <> "C350" Then 'run the command unless EOF'
Application.Run ("GrabDataFromMinutes")
MsgBox "I got here"
Location = ActiveCell.Address
End If
End If
Loop
End Sub
This is the end solution to my own problem. The information provided by other answers contributed to fixing my problems. Thanks Everyone!
Public Sub CopyAllData()
'Declarations'
Dim CellValue As String
Dim LastRow As Integer
Dim CurrentRow As Integer
Application.Run ("CopyMinuteHeaders") 'Copy Headers and setup sheet'
'Initialize values'
CellValue = ActiveCell.Value
CurrentRow = ActiveCell.Row
LastRow = ActiveSheet.UsedRange.Rows.Count
LastRow = LastRow + 1
Do While LastRow <> CurrentRow
If CurrentRow >= LastRow Then
Exit Sub
End If
If CellValue = "" Then 'If cell is empty skip row'
Do While CellValue = "" 'Skip multiple rows that are empty'
ActiveCell.Offset(rowOffset:=1, ColumnOffset:=0).Activate
CellValue = ActiveCell.Value
Loop
End If
If CurrentRow <> LastRow Then
Application.Run ("GrabDataFromMinutes")
CurrentRow = ActiveCell.Row
CellValue = ActiveCell.Value
End If
Loop
End Sub
I don't know what your GrabDataFromMinutes macro does, I would assume it deals with the active cell though. Usually I would try not to supply a code using select or activate. If you were to supply the code for GrabDataFromMinutes maybe a better solution could be found for you.
In the meantime practice with this code, it will select only the non-blank cells in column A and call the otherMacro.
Sub LoopNonBlanks()
Dim Lstrw As Long
Dim Rng As Range
Dim c As Range
Lstrw = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range("A2:A" & Lstrw).SpecialCells(xlCellTypeConstants, 23)
For Each c In Rng.Cells
c.Select
otherMacro 'calls the otherMacro
Next c
End Sub
Sub otherMacro()
MsgBox "This is the other macro " & ActiveCell.Address & " value is ..." & ActiveCell.Value
End Sub