Staying on the active worksheet - excel

I have a workbook with monthly worksheets. One for Emails and one for Calls and I have created two userForms for data entry, one for Emails and one for Calls.
The forms do the job and they enter date in the right place but if I have selected the "August 18 Email" sheet and use the Email form, once the form is submitted it jumps to display the "August 18 Calls" sheet.
I just want it to stay in the selected worksheet, in this case "August 18 Email".
The code for the Emails form is the one below and the one for the Calls is nearly the same but only changing this line : Set ws = Sheets(Format(Date, "mmmm yy") & " calls")
Private Sub CommandButton2_Click()
Dim lRow As Long
Dim ws As Worksheet
Set ws = ActiveSheet
Set ws = Sheets(Format(Date, "mmmm yy") & " emails")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With ws
If Me.txtDateBox.Value = "" Then
.Cells(lRow, 1).Value = Format(Date, "dd/mmm/yy")
Else
.Cells(lRow, 1).Value = Me.txtDateBox.Value
End If
myVar = ""
For x = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(x) Then
If myVar = "" Then
myVar = Me.ListBox2.List(x, 0)
Else
myVar = myVar & "," & Me.ListBox2.List(x, 0)
End If
End If
Next x
.Cells(lRow, 11).Value = myVar
myVarSign = ""
For x = 0 To Me.ListBox3.ListCount - 1
If Me.ListBox3.Selected(x) Then
If myVarSign = "" Then
myVarSign = Me.ListBox3.List(x, 0)
Else
myVarSign = myVarSign & "," & Me.ListBox3.List(x, 0)
End If
End If
Next x
.Cells(lRow, 12).Value = myVarSign
myVarTheme = ""
For x = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(x) Then
If myVarTheme = "" Then
myVarTheme = Me.ListBox1.List(x, 0)
Else
myVarTheme = myVarTheme & "," & Me.ListBox1.List(x, 0)
End If
End If
Next x
.Cells(lRow, 14).Value = myVarTheme
.Cells(lRow, 2).Value = Me.Time.Value
.Cells(lRow, 3).Value = Me.ComboBox1.Value
.Cells(lRow, 4).Value = Me.ComboBox2.Value
.Cells(lRow, 5).Value = Me.ComboBox3.Value
.Cells(lRow, 6).Value = Me.ComboBox4.Value
.Cells(lRow, 7).Value = Me.ComboBox5.Value
.Cells(lRow, 8).Value = Me.ComboBox15.Value
.Cells(lRow, 9).Value = Me.ComboBox6.Value
.Cells(lRow, 10).Value = Me.ComboBox7.Value
.Cells(lRow, 13).Value = Me.ComboBox11.Value
.Cells(lRow, 15).Value = Me.ComboBox16.Value
.Cells(lRow, 16).Value = Me.TextBox2.Value
End With
Me.txtDateBox.Value = ""
Me.Time.Value = ""
Me.ComboBox1.Value = ""
Me.ComboBox2.Value = ""
Me.ComboBox3.Value = ""
Me.ComboBox4.Value = ""
Me.ComboBox5.Value = ""
Me.ComboBox6.Value = ""
Me.ComboBox7.Value = ""
Me.ComboBox11.Value = ""
Me.ComboBox16.Value = ""
Me.ComboBox15.Value = ""
Me.TextBox2.Value = ""
Dim iCount As Integer
For iCount = 0 To Me!ListBox1.ListCount
Me!ListBox1.Selected(iCount) = False
Next iCount
For iCount = 0 To Me!ListBox2.ListCount
Me!ListBox2.Selected(iCount) = False
Next iCount
For iCount = 0 To Me!ListBox3.ListCount
Me!ListBox3.Selected(iCount) = False
Next iCount
End Sub
It could be improved a lot but I am happy if after submission the worksheet in view stays instead to jumping to another one.
As you can see I am only beginning (I have managed to create this with help of others).

If you remove any instances of .Select or .Activate on worksheet, range, or cell objects, your sheet shouldn't change.
If that is not an option, another solution would be to note what sheet you are on when the code is called and then Activate that sheet before ending your sub. Since we do not see all of the userform code, you will have to strategically decide where this goes (as mentioned by #K.Davis, nothing shown switches the sheet so it must be happening in some other code).
When the macro/userform is launched:
Dim StartSheet as Worksheet
Set StartSheet = ActiveSheet
Then, before exiting macro/userform:
StartSheet.Activate
You may have to pass this along as a parameter depending on how your code is structured.

Related

Excel/VBA Summary sheet - overwriting data

first of all a thank you for previous help! You learned me more and still am learning everyday to code better :)
In the previous posts I wrote about having a userform for some input. Then it searches for the persons name in all the sheets in the workbook and writes the data as specified. In my workbook I would like to dedicate 1 sheet to summarize from all other sheets.
Now here is where an error occurs. The data is written down on the summary sheet, but when I select another name, the first row (lRow, 3) gets re-written.
I think that my mistake occurs with the lastrow statement. I have tried the .Range("C"...) version to find the last used row. Now it also finds the last used row, but also somehow overwrites the first row with values other then the selected name
Dim lRow As Long
Dim Ws As Worksheet
Dim Naam As String
Dim xTo As String
Dim xBCC As String
With Me.ComboBox1
i = .ListIndex
If i < 0 Then
MsgBox "Er is niemand geselecteerd.", vbExclamation
Exit Sub
End If
xTo = .List(i, 1)
xBCC = .List(i, 2)
Naam = .List(i, 3)
End With
Set Ws = Worksheets(ComboBox1.Value)
lRow = Ws.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row
With Ws
.Cells(lRow, 3).Value = Format(Date, "DD-MM-YYYY") & " " & Format(Time, "HH:MM")
If chk1.Value Then .Cells(lRow, 5).Value = 1
If chk1.Value = False Then .Cells(lRow, 5).Value = 0
If chk2.Value Then .Cells(lRow, 6).Value = 1
If chk2.Value = False Then .Cells(lRow, 6).Value = 0
If chk3.Value Then .Cells(lRow, 7).Value = 1
If chk3.Value = False Then .Cells(lRow, 7).Value = 0
If chk4.Value Then .Cells(lRow, 8).Value = 1
If chk4.Value = False Then .Cells(lRow, 8).Value = 0
If chk5.Value Then .Cells(lRow, 9).Value = 1
If chk5.Value = False Then .Cells(lRow, 9).Value = 0
If chk6.Value Then .Cells(lRow, 10).Value = 1
If chk6.Value = False Then .Cells(lRow, 10).Value = 0
If chk7.Value Then .Cells(lRow, 11).Value = 1
If chk7.Value = False Then .Cells(lRow, 11).Value = 0
If chk8.Value Then .Cells(lRow, 12).Value = 1
If chk8.Value = False Then .Cells(lRow, 12).Value = 0
If chk9.Value Then .Cells(lRow, 13).Value = 1
If chk9.Value = False Then .Cells(lRow, 13).Value = 0
If 10.Value Then .Cells(lRow, 14).Value = 1
If 10.Value = False Then .Cells(lRow, 14).Value = 0
If chk11.Value Then .Cells(lRow, 15).Value = 1
If chk11.Value = False Then .Cells(lRow, 15).Value = 0
If chk12.Value Then .Cells(lRow, 16).Value = 1
If chk12.Value = False Then .Cells(lRow, 16).Value = 0
If chk13.Value Then .Cells(lRow, 17).Value = 1
If chk13.Value = False Then .Cells(lRow, 17).Value = 0
End With
Set Ws = Worksheets("Team totaal")
With Ws
.Cells(lRow, 3).Value = Naam
.Cells(lRow, 4).Value = Format(Date, "DD-MM-YYYY") & " " & Format(Time, "HH:MM")
If chk1.Value Then .Cells(lRow, 6).Value = 1
If chk1.Value = False Then .Cells(lRow, 6).Value = 0
If chk2.Value Then .Cells(lRow, 7).Value = 1
If chk2.Value = False Then .Cells(lRow, 7).Value = 0
If chk3.Value Then .Cells(lRow, 8).Value = 1
If chk3.Value = False Then .Cells(lRow, 8).Value = 0
If chk4.Value Then .Cells(lRow, 9).Value = 1
If chk4.Value = False Then .Cells(lRow, 9).Value = 0
If chk5.Value Then .Cells(lRow, 10).Value = 1
If chk5.Value = False Then .Cells(lRow, 10).Value = 0
If chk6.Value Then .Cells(lRow, 11).Value = 1
If chk6.Value = False Then .Cells(lRow, 11).Value = 0
If chk7.Value Then .Cells(lRow, 12).Value = 1
If chk7.Value = False Then .Cells(lRow, 12).Value = 0
If chk8.Value Then .Cells(lRow, 13).Value = 1
If chk8.Value = False Then .Cells(lRow, 13).Value = 0
If chk9.Value Then .Cells(lRow, 14).Value = 1
If chk9.Value = False Then .Cells(lRow, 14).Value = 0
If chk10.Value Then .Cells(lRow, 15).Value = 1
If chk10.Value = False Then .Cells(lRow, 15).Value = 0
If chk11.Value Then .Cells(lRow, 16).Value = 1
If chk11.Value = False Then .Cells(lRow, 16).Value = 0
If chk12.Value Then .Cells(lRow, 17).Value = 1
If chk12.Value = False Then .Cells(lRow, 17).Value = 0
If chk13.Value Then .Cells(lRow, 18).Value = 1
If chk13.Value = False Then .Cells(lRow, 18).Value = 0
End With
Maybe this is not the correct way to set up a summary sheet and someone has a more efficient way to do this. Any help is welcome
The best way to approach solving a problem with code is to break it down to very simple functions and sub routines.
Here is my thought processes.
We are probably going to be referring to the "Team totaal" worksheet in many of of the macros. Ws is meaningless. I would change the code name of the worksheet to wsTeamTotaal. but this also works:
Function wsTeamTotaal() As Worksheet
Set wsTeamTotaal = ThisWorkbook.Worksheets("Team totaal")
End Function
Next I know that I need to target the next available row in wsTeamTotaal. This should do it.
Function TeamTotalNewRow() As Range
With wsTeamTotaal
Set TeamTotalNewRow = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
End With
End Function
Do I write a 60 line script to test it? Hell no!! This function selects the first cell in the new row.
Sub GotoTeamTotalNewRow()
Application.Goto TeamTotalNewRow
End Sub
Okay now I write a script to gather all the information and append the row, right? Wrong! Writing a function that accepts variable number of arguments using a ParamArray simplifies the process. Now I can append 1 value of 60+ values without any major modifications.
Sub AppendTeamTotaalRow(ParamArray Args() As Variant)
With TeamTotalNewRow
.Resize(1, UBound(Args) + 1).Value = Args
End With
End Sub
So time to spend a hour writing a userform, gather the data and then testing the append method. Of course not. What's easier to test, a userform packed full of functionality and controls or one simple sub routine?
Sub TestAddNewTeamTotalRow()
Dim TimeStamp As String
TimeStamp = Format(Date, "DD-MM-YYYY") & " " & Format(Time, "HH:MM")
AppendTeamTotaalRow TimeStamp, True, False, True, False
End Sub
Notice that I broke this problem do to it's simplest terms and solved each problem separately. We now have 2 functions, a sub routine and two tests. Each routine performs a single task and no routine has more than 5 lines. Simplify, simplify, simplify, it's that simple.
Complete Code
Function TeamTotalNewRow() As Range
With wsTeamTotaal
Set TeamTotalNewRow = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
End With
End Function
Function wsTeamTotaal() As Worksheet
Set wsTeamTotaal = ThisWorkbook.Worksheets("Team totaal")
End Function
Sub GotoTeamTotalNewRow()
Application.Goto TeamTotalNewRow
End Sub
Sub AppendTeamTotaalRow(ParamArray Args() As Variant)
With TeamTotalNewRow
TeamTotalNewRow.Resize(1, UBound(Args) + 1).Value = Args
End With
End Sub
Sub TestAddNewTeamTotalRow()
Dim TimeStamp As String
TimeStamp = Format(Date, "DD-MM-YYYY") & " " & Format(Time, "HH:MM")
AppendTeamTotaalRow TimeStamp, True, False, True, False
End Sub

Why ActiveX Command button does not run all codes in my VBA UserForm?

I am a complete novice at Excel VBA and I am currently attempting a project on Excel VBA. I have created a UserForm that would allow the user to enter data onto the Excel Sheet by completing the fields in the UserForm. I have tested all the codes individually and they have worked fine.
For the user to access the UserForm, I have added an ActiveX Command Button on a separate sheet on the same workbook. However, when accessing the UserForm from the ActiveX Command Button, some of the codes do not run (mainly the code that flags out the duplicate entry, as well as the code that generates serial numbers).
Where did I go wrong in my code?
This is my code to adding new data as well as the code to flag out duplicate entries. When opening the UserForm from the ActiveX Command Button, adding new data works fine but it does not flag out duplicate entries in the data. (However, testing the code itself in VBA works perfectly fine).
Private Sub cmdAddNewCustomer_Click()
Dim count As Long
Dim lastrow As Long
Dim lCustomerID As String
Dim ws As Worksheet
Set ws = Worksheets("Customer Data")
'find first empty row in database
lrow = ws.Cells.Find(what:="*", searchorder:=xlRows, _
Searchdirection:=xlPrevious, LookIn:=xlValues).Row + 1
lCustomerID = txtCustomerID
count = 0
With ws
For currentrow = 1 To lrow
If lCustomerID = Cells(currentrow, 1) Then
count = count + 1
End If
If count > 1 Then
.Cells(currentrow, 1).Value = ""
.Cells(currentrow, 2).Value = ""
.Cells(currentrow, 3).Value = ""
.Cells(currentrow, 4).Value = ""
.Cells(currentrow, 5).Value = ""
.Cells(currentrow, 6).Value = ""
.Cells(currentrow, 7).Value = ""
.Cells(currentrow, 8).Value = ""
.Cells(currentrow, 9).Value = ""
.Cells(currentrow, 10).Value = ""
.Cells(currentrow, 11).Value = ""
.Cells(currentrow, 12).Value = ""
.Cells(currentrow, 13).Value = ""
.Cells(currentrow, 14).Value = ""
MsgBox ("CustomerID already exists!")
End If
If count = 0 Then
.Cells(lrow, 1).Value = Me.txtCustomerID.Value
.Cells(lrow, 2).Value = Me.txtCustomerName.Value
.Cells(lrow, 3).Value = Me.cboCustomerStatus.Value
.Cells(lrow, 4).Value = Me.txtContactPerson.Value
.Cells(lrow, 5).Value = Me.cboDepartment.Value
.Cells(lrow, 6).Value = Me.txtPosition.Value
.Cells(lrow, 7).Value = Me.cboRoleType.Value
.Cells(lrow, 8).Value = Me.txtofficeHP1.Value
.Cells(lrow, 9).Value = Me.txtOfficeHP2.Value
.Cells(lrow, 10).Value = Me.txtMobileHP1.Value
.Cells(lrow, 11).Value = Me.txtMobileHP2.Value
.Cells(lrow, 12).Value = Me.txtEmail1.Value
.Cells(lrow, 13).Value = Me.txtEmail2.Value
.Cells(lrow, 14).Value = Me.txtEmail3.Value
End If
Next currentrow
End With
'clear the data
Me.txtCustomerName.Value = ""
Me.cboCustomerStatus.Value = ""
Me.txtContactPerson.Value = ""
Me.cboDepartment.Value = ""
Me.txtPosition.Value = ""
Me.cboRoleType.Value = ""
Me.txtofficeHP1.Value = ""
Me.txtOfficeHP2.Value = ""
Me.txtMobileHP1.Value = ""
Me.txtMobileHP2.Value = ""
Me.txtEmail1.Value = ""
Me.txtEmail2.Value = ""
Me.txtEmail3.Value = ""
End Sub
This is the code to generate serial numbers. (Same problem, does not work when accessed via ActiveX Command Button but works fine when tested individually in VBA).
Sub FindCustomerID()
Dim lastrow
Dim lastnum As Long
Dim ws As Worksheet
Set ws = Worksheets("Customer Data")
If Me.cboCountry = "" Or Me.txtCustomerName = "" Then
Exit Sub
End If
serialno = 1
lastrow = ws.Cells(Rows.count, 1).End(xlUp).Row
CountryCode = UCase(Left(Me.cboCountry, 3))
CustomerCode = UCase(Left(Me.txtCustomerName, 10))
'assemble them into CustomerID
CustomerID = CountryCode & CustomerCode & serialno
For currentrow = 2 To lastrow
If CustomerID = Cells(currentrow, 1) Then
'find last number that applies
serialno = serialno + 1
End If
're-assign customerID with new serial number
CustomerID = CountryCode & CustomerCode & serialno
Next currentrow
Me.lblCustomerID = CustomerID
End Sub
And lastly, this is the code from the ActiveX Command Button that brings out the UserForm.
Private Sub cmdNCustomerData_Click()
frmCustomerdata.Show
End Sub
The cause of the problem you described is a missing . to qualify Cells(currentrow, 1). Because you added the ActiveX button to a different sheet, the line
If lCustomerID = Cells(currentrow, 1) Then
accesses Cells(currentrow, 1) of that sheet. To fix this the range needs to be qualified with a . to become
If lCustomerID = .Cells(currentrow, 1) Then
I would also take
If count = 0 Then
.
.
.
End If
outside the loop. You are repeating these lines many times unnecessarily.
The first block of code then becomes:
Private Sub cmdAddNewCustomer_Click()
Dim count As Long
Dim lastrow As Long
Dim lCustomerID As String
Dim ws As Worksheet
Set ws = Worksheets("Customer Data")
'find first empty row in database
lrow = ws.Cells.Find(what:="*", searchorder:=xlRows, _
Searchdirection:=xlPrevious, LookIn:=xlValues).Row + 1
lCustomerID = txtCustomerID
count = 0
With ws
' Count backward to delete rows completely
For currentrow = lrow - 1 To 1 Step -1
If lCustomerID = .Cells(currentrow, 1) Then
count = count + 1
End If
If count > 1 Then
.Cells(currentrow, 1).Resize(1, 14).ClearContents
' Uncomment the following line to delete the whole row completely
'.Rows(currentrow).Delete
End If
Next currentrow
If count > 1 Then
MsgBox (count - 1 " duplicates of CustomerID found and cleared!")
ElseIf count = 0 Then
.Cells(lrow, 1).Value = Me.txtCustomerID.Value
.Cells(lrow, 2).Value = Me.txtCustomerName.Value
.Cells(lrow, 3).Value = Me.cboCustomerStatus.Value
.Cells(lrow, 4).Value = Me.txtContactPerson.Value
.Cells(lrow, 5).Value = Me.cboDepartment.Value
.Cells(lrow, 6).Value = Me.txtPosition.Value
.Cells(lrow, 7).Value = Me.cboRoleType.Value
.Cells(lrow, 8).Value = Me.txtofficeHP1.Value
.Cells(lrow, 9).Value = Me.txtOfficeHP2.Value
.Cells(lrow, 10).Value = Me.txtMobileHP1.Value
.Cells(lrow, 11).Value = Me.txtMobileHP2.Value
.Cells(lrow, 12).Value = Me.txtEmail1.Value
.Cells(lrow, 13).Value = Me.txtEmail2.Value
.Cells(lrow, 14).Value = Me.txtEmail3.Value
End If
End With
'clear the data
Me.txtCustomerName.Value = ""
Me.cboCustomerStatus.Value = ""
Me.txtContactPerson.Value = ""
Me.cboDepartment.Value = ""
Me.txtPosition.Value = ""
Me.cboRoleType.Value = ""
Me.txtofficeHP1.Value = ""
Me.txtOfficeHP2.Value = ""
Me.txtMobileHP1.Value = ""
Me.txtMobileHP2.Value = ""
Me.txtEmail1.Value = ""
Me.txtEmail2.Value = ""
Me.txtEmail3.Value = ""
End Sub
In the FindCustomerID subroutine you have exactly the same problem with the line
If CustomerID = Cells(currentrow, 1) Then
as Cells(currentrow, 1) is not qualified and therefore, should become
If CustomerID = ws.Cells(currentrow, 1) Then
You are also reassigning the CustomerID many times unnecessarily. I would take the reassignment inside the If statement and the loop will become
For currentrow = 2 To lastrow
If CustomerID = ws.Cells(currentrow, 1) Then
'find last number that applies
serialno = serialno + 1
're-assign customerID with new serial number
CustomerID = CountryCode & CustomerCode & serialno
End If
Next currentrow
This way CustomerID is only reassigned if and only if serialno changes.

Loop through ListBox Multiselection

I'm trying to loop through multiselected list of listbox in excel. but it throws Error "Next without For"
UserForm connects three books. Firstдн, macro should check for matches in book "ToolsDır". If there is a tool, then transfer it from responsible to recipient. then enter this transaction in "TOOLSJOURNAL". and go through all the selected elements of the list box doing the same action. I hope I could explain the problem
Private Sub cmbOK_Click()
Dim wbd, wbs As String
wbd = "...\TOOLS\TOOLSJOURNAL.xlsm"
wbs = "...\TOOLS\TOOLSDIR.xlsm"
If Trim(Me.cboCity.Value) = "" Or Trim(Me.cboReciever.Value) = "" Then
Me.TextDate.SetFocus
MsgBox ("Tool is already in use!")
Else
GetObject (wbs)
Dim lnItem As Long
For lnItem = 0 To Me.ListBox.ListCount - 1
If Me.ListBox.Selected(lnItem) Then
Dim ws As Worksheet
Set ws = Workbooks("TOOLSDIR").Worksheets("TABLE")
Dim rn1, rn2, rn3 As Range
Set rn1 = ws.Range("ID")
Set rn2 = ws.Range("EMPLOYEES")
Set rn3 = ws.Range("DATA")
Dim i, j, k, l As Integer
i = Application.Match(Me.ListBox.Selected(lnItem), ws.Range("ID"), 0)
j = Application.Match(Me.cboRespName.Value, ws.Range("EMPLOYEES"), 0)
k = Application.Match(Me.cboRecName.Value, ws.Range("EMPLOYEES"), 0)
l = rn3.Cells(i, j)
If rn3.Cells(i, j).Value <> 1 Then
MsgBox ("Fill Blank ")
Application.DisplayAlerts = False
Workbooks("TOOLSDIR").Close (False)
Else: rn3.Cells(i, j) = rn3.Cells(i, j) - 1
rn3.Cells(i, k) = rn3.Cells(i, k) + 1
End If
Application.DisplayAlerts = False
Workbooks("TOOLSDIR").Close (True)
With GetObject(wbd)
Dim Database As Worksheet
Set Database = Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL")
Dim NextRow As Long
NextRow = Database.Cells(Database.Rows.Count, 3).End(xlUp).Offset(1, 0).Row
If Database.Range("B4").Value = "" And Database.Range("C4").Value = "" Then
NextRow = NextRow - 1
End If
Database.Cells(NextRow, 3).Value = Me.TextDate.Value
Database.Cells(NextRow, 4).Value = Me.TextPurchaseDate
Database.Cells(NextRow, 5).Value = Me.TextFirstDate.Value
Database.Cells(NextRow, 6).Value = Me.TextDayTotal.Value
Database.Cells(NextRow, 7).Value = Me.cboRegion.Value
Database.Cells(NextRow, 8).Value = Me.cboCity.Value
Database.Cells(NextRow, 9).Value = Me.cboResponsible.Value
Database.Cells(NextRow, 10).Value = Me.cboRespName
Database.Cells(NextRow, 11).Value = Me.ListBox.List(lnItem, 1).Value
Database.Cells(NextRow, 12).Value = Me.ListBox.List(lnItem, 2).Value
Database.Cells(NextRow, 13).Value = Me.ListBox.List(lnItem, 3).Value
Database.Cells(NextRow, 14).Value = Me.cboReciever.Value
Database.Cells(NextRow, 15).Value = Me.cboRecName.Value
Database.Range("B4").Formula = "=If(ISBLANK(C4), """", COUNTA($C$4:C4))"
If NextRow > 4 Then
Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL").Activate
Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL").Range("B4").Select
Selection.AutoFill Destination:=Range("b4:b" & NextRow)
Range("b4:b" & NextRow).Select
End If
End With
Application.DisplayAlerts = False
Workbooks("TOOLSJOURNAL").Close (True)
Next lnItem
End If
Call resetForm
End Sub

How To: Excel VBA Command Button Enters UserForm Values to Current Row?

I currently have a UserForm "UserForm1" that takes values (Lesson, Instructor, Start Time, etc.) from ComboBoxes and saves them to a designated sheet "InstructorHours". The CommandButton "Save" saves the selected values in the next available line on the "InstructorHours" sheet. What I'm having trouble with is having the CommandButton save the same information into a currently selected row on another Worksheet "Calendar". Ideally I would like to click within a row on my "Calendar" sheet and input the values from the User from into the row I've selected.
Private Sub CommandButton1_Click()
'Copy input values to sheet.
Dim lRow As Long
'next available row
Dim ws As Worksheet
Set ws = Worksheets("InstructorHours")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With ws
.Cells(lRow, 1).Value = Me.ComboBox1.Value
.Cells(lRow, 2).Value = Me.ComboBox2.Value
.Cells(lRow, 3).Value = Me.ComboBox3.Value
.Cells(lRow, 4).Value = Me.ComboBox4.Value
.Cells(lRow, 5).Value = Me.ComboBox5.Value
.Cells(lRow, 6).Value = Me.ComboBox6.Value
.Cells(lRow, 7).Value = Me.TextBox1.Value
End With
'Clear input controls.
Me.ComboBox1.Value = ""
Me.ComboBox2.Value = ""
Me.ComboBox3.Value = ""
Me.ComboBox4.Value = ""
Me.ComboBox5.Value = ""
Me.ComboBox6.Value = ""
End Sub
Any and all help is much appreciated. Thank you.
In general, if you want to work on something active, you would want something "Active" (e.g. ActiveSheet or ActiveCell) for your active-selection activities.
I would recommend another Command Button for the following (Writing this up off the top of my head, haven't verified the code):
Private Sub CommandButton2_Click()
'Input based on the selection
ActiveCell.Value = Me.ComboBox1.Value
ActiveCell.Offset(1,0).Value = Me.ComboBox2.Value
ActiveCell.Offset(2,0).Value = Me.ComboBox3.Value
ActiveCell.Offset(3,0).Value = Me.ComboBox4.Value
ActiveCell.Offset(4,0).Value = Me.ComboBox5.Value
ActiveCell.Offset(5,0).Value = Me.ComboBox6.Value
ActiveCell.Offset(6,0).Value = Me.TextBox1.Value
'Clear input controls.
Me.ComboBox1.Value = ""
Me.ComboBox2.Value = ""
Me.ComboBox3.Value = ""
Me.ComboBox4.Value = ""
Me.ComboBox5.Value = ""
Me.ComboBox6.Value = ""
End Sub
That should provide, at least, a starting point.

Copy-paste cell values to other sheets

I am trying to put together some codes that I found here and there to build up a small inventory, sales program. I am stuck at a point where the customer basket is finalized and sold items in the basket should be saved in relevant sheets.
As an example,basket data is in sheet1 (A4:g22), needs to be written to sheet2 and sheet3 with finding the first empty cell in column A. Thank you very much for your help in advance.
Private Sub EKSKAYDET_Click()
If Not IsNumeric(Me.eksmiktartxt.Value) Then
MsgBox "Miktari Kontrol Ediniz!"
Me.eksmiktartxt.SetFocus
Exit Sub
End If
If Not IsNumeric(Me.eksreznobox.Value) Then
MsgBox "ÜRÜN KODUNU Kontrol Ediniz!"
Me.eksreznobox.SetFocus
Exit Sub
End If
If eksreznobox.Value = "" Then
MsgBox "ÜRÜN KODU Seçmelisiniz!"
Me.eksreznobox.SetFocus
Exit Sub
End If
If TextBox23 = 0 And TextBox19 = 0 And TextBox20 = 0 And TextBox21 = 0 And TextBox22 = 0 Then
MsgBox "ÖDEME MİKTARI Girmelisiniz!": Exit Sub
Me.TextBox19.SetFocus
End If
If TextBox25.Value = 0 Then
MsgBox "SEPET BOŞ!"
Exit Sub
End If
If TextBox19 = "" And TextBox20 = "" And TextBox21 = "" And TextBox22 = "" And TextBox23 = "" Then
MsgBox "Tutar Girmelisiniz!":
Exit Sub
End If
If eksreznobox.ListCount = 0 Then Exit Sub
ry_bul = eksreznobox.ListIndex + 3
eksadI = Sheets("STOKKARTLARI").Range("D" & ry_bul).Value
EKSSOYADI = Sheets("STOKKARTLARI").Range("E" & ry_bul).Value
textbox12 = Sheets("STOKKARTLARI").Range("h" & ry_bul).Value
TextBox15 = Sheets("STOKKARTLARI").Range("F" & ry_bul).Value
ekstutartxt.Value = eksmiktartxt.Value * textbox12.Value
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("SATISHAREKETLERİ")
lRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
If Trim(Me.eksreznobox.Value) = "" Then
Me.ekreznobox.SetFocus
MsgBox "Lütfen ÜRÜN KODUNU Girin!"
Exit Sub
End If
With ws
.Cells(lRow, 3).Value = Me.eksreznobox.Value
.Cells(lRow, 1).Value = Me.ekstarihtXT.Value
.Cells(lRow, 4).Value = Me.eksadI.Value
.Cells(lRow, 7).Value = Me.eksmiktartxt.Value
.Cells(lRow, 9).Value = Me.ekstutartxt.Value
.Cells(lRow, 8).Value = Me.textbox12.Value
.Cells(lRow, 5).Value = Me.EKSSOYADI.Value
.Cells(lRow, 6).Value = Me.TextBox15.Value
.Cells(lRow, 2).Value = Me.TextBox26.Value
Dim llRow As Long
Dim ws1 As Worksheet
Set ws1 = Worksheets("STOK")
llRow = ws1.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
If Trim(Me.eksreznobox.Value) = "" Then
Me.ekreznobox.SetFocus
MsgBox "Lütfen ÜRÜN KODUNU Girin!"
Exit Sub
End If
With ws1
.Cells(llRow, 3).Value = Me.eksreznobox.Value
.Cells(llRow, 1).Value = Me.ekstarihtXT.Value
.Cells(llRow, 4).Value = Me.eksadI.Value
.Cells(llRow, 7).Value = Me.eksmiktartxt.Value
.Cells(llRow, 9).Value = Me.ekstutartxt.Value
.Cells(llRow, 8).Value = Me.textbox12.Value
.Cells(llRow, 5).Value = Me.EKSSOYADI.Value
.Cells(llRow, 6).Value = Me.TextBox15.Value
.Cells(llRow, 2).Value = Me.TextBox26.Value
.Cells(llRow, 11).Value = Me.TextBox27.Value
ekstutartxt.Value = eksmiktartxt.Value * textbox12.Value
End With
Dim lllRow As Long
Dim ws2 As Worksheet
Set ws2 = Worksheets("kasa")
lllRow = ws2.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
If Trim(Me.eksreznobox.Value) = "" Then
Me.ekreznobox.SetFocus
MsgBox "Lütfen ÜRÜN KODUNU Girin!"
Exit Sub
End If
Me.TextBox52.Value = "SATIŞ"
With ws2
.Cells(lllRow, 1).Value = Me.ekstarihtXT.Value
.Cells(lllRow, 5).Value = Me.TextBox19.Value
.Cells(lllRow, 6).Value = Me.TextBox20.Value
.Cells(lllRow, 7).Value = Me.TextBox21.Value
.Cells(lllRow, 9).Value = Me.TextBox23.Value
.Cells(lllRow, 3).Value = Me.TextBox51.Value
.Cells(lllRow, 2).Value = Me.TextBox26.Value
.Cells(lllRow, 4).Value = Me.TextBox52.Value
ekstutartxt.Value = eksmiktartxt.Value * textbox12.Value
End With
With kayit_formu.ListBox6
.BackColor = vbWhite
.ColumnCount = 9
.ColumnWidths = "50;33;45;55;60;55;42;43;60"
.ForeColor = vbBlack
If Sheets("SATISHAREKETLERİ").Range("A1") = Empty Then
.RowSource = Empty
Else
.RowSource = "SATISHAREKETLERİ!a1:i" & [SATISHAREKETLERİ!A1048500].End(3).Row
End If
End With
MsgBox "Bir Kayit Yapildi!"
End With
Me.TextBox25.Text = CStr(ThisWorkbook.Sheets("SEPET").Range("G1").Value)
Me.TextBox24.Text = CStr(ThisWorkbook.Sheets("SEPET").Range("G2").Value)
End Sub
You can try this code.
Worksheets(“Sheet1″).Range(“A1:G22″).Copy _
Destination:=Worksheets(“Sheet2″).Range(“E5″)

Resources