Trying to make my VBA run a little bit faster - excel

I am New to VBA, so my codes are usually very slow/suboptimized.
In one of my programs I have cells in the sheet that has to be filled when the user press a button, the renges change depending on the button but the concept is the same.
So I did this monstrosity:
Cells((Range("namedrange").Row + 5), 1).Value = ThisWorkbook.Sheets(5).Cells(4, 7).Value
Cells((Range("namedrange").Row + 5), 3).Value = ThisWorkbook.Sheets(5).Cells(4, 8).Value
Cells((Range("namedrange").Row + 5), 5).Value = ThisWorkbook.Sheets(5).Cells(4, 9).Value
Cells((Range("namedrange").Row + 5), 8).Value = ThisWorkbook.Sheets(5).Cells(4, 10).Value
Cells((Range("namedrange").Row + 5) + 1, 1).Value = ThisWorkbook.Sheets(5).Cells(5, 7).Value
Cells((Range("namedrange").Row + 5) + 1, 3).Value = ThisWorkbook.Sheets(5).Cells(5, 8).Value
Cells((Range("namedrange").Row + 5) + 1, 5).Value = ThisWorkbook.Sheets(5).Cells(5, 9).Value
Cells((Range("namedrange").Row + 5) + 1, 8).Value = ThisWorkbook.Sheets(5).Cells(5, 10).Value
but later changed to:
With Range("namedrange")
.Offset(5).Columns(1).Value = ThisWorkbook.Sheets(3).Cells(4, 7).Value
.Offset(5).Columns(3).Value = ThisWorkbook.Sheets(3).Cells(4, 8).Value
.Offset(5).Columns(5).Value = ThisWorkbook.Sheets(3).Cells(4, 9).Value
.Offset(5).Columns(8).Value = ThisWorkbook.Sheets(3).Cells(4, 10).Value
.Offset(6).Columns(1).Value = ThisWorkbook.Sheets(3).Cells(5, 7).Value
.Offset(6).Columns(3).Value = ThisWorkbook.Sheets(3).Cells(5, 8).Value
.Offset(6).Columns(5).Value = ThisWorkbook.Sheets(3).Cells(5, 9).Value
.Offset(6).Columns(8).Value = ThisWorkbook.Sheets(3).Cells(5, 10).Value
End With
which is a bit faster, however I feel that it is still suboptimized. And I would like to know if there is a way to make it cleaner/more elegant.
Just to be noted that there are discontinuities in the columns, e.g. it starts in the 1st columns but jumps to the 3rd and then to the 5th and at last to the 8th.
The code works but it is slow, I just want a way to make it faster/cleaner.

Using Variables
In regards to efficiency, that's about it: you're using the most efficient way to copy values from one cell to another aka copying by assignment.
If you want it to be more flexible, maintainable, and readable(?), here are some ideas.
Additionally, you can move the remaining magic numbers and text to constants at the beginning of the code or even use the constants as arguments.
Sub CopyValues()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Specify the worksheet if you know it.
'Dim dnrg As Range: Set dnrg = wb.Sheets("Sheet1").Range("NamedRange")
' Otherwise, make sure the workbook is active.
If Not wb Is ActiveWorkbook Then wb.Activate
Dim dnrg As Range: Set dnrg = Range("NamedRange")
Dim drg As Range: Set drg = dnrg.Range("A1,C1,E1,H1").Offset(5)
Dim cCount As Long: cCount = drg.Cells.Count
' If you know the tab name, use it instead of the index (3).
Dim sws As Worksheet: Set sws = wb.Sheets(3)
Dim srg As Range: Set srg = sws.Range("G4").Resize(, cCount)
Dim r As Long, c As Long
For r = 0 To 1
For c = 1 To cCount
drg.Offset(r).Cells(c).Value = srg.Offset(r).Cells(c).Value
Next c
Next r
End Sub

Accessing Excel for values from VBA is a slow operation and this adds up when you make multiple requests. When you are essentially retrieving the same information on a repetitive basis there are two two methods can be used to reduce access times.
Replace a lookup with a calculated value
Use a with statement
Thus you code could be written as
Dim myCol as long
myCol =Range("namedrange").Row + 5
With ThisWorkook.Sheets(5)
Cells(myCol, 1).Value = .Cells(4, 7).Value
Cells(myCol, 3).Value = .Cells(4, 8).Value
Cells(myCol, 5).Value = .Cells(4, 9).Value
Cells(myCol, 8).Value = .Cells(4, 10).Value
myCol=myCol+1 ' trivial example
Cells(mycol, 1).Value = .Cells(5, 7).Value
Cells(myCol, 3).Value = .Cells(5, 8).Value
Cells(myCol, 5).Value = .Cells(5, 9).Value
Cells(myCol, 8).Value = .Cells(5, 10).Value
End with
Please also install the free, opensource, and fantastic Rubberduck addin for VBA. The code inspections will help you write VBA that is much more correct.

I wonder what would happen if you use all the .Offset parameters, row and column. Example:
With Range("namedrange")
.Offset(5, 0).Value = ThisWorkbook.Sheets(3).Cells(4, 7).Value
.Offset(5, 2).Value = ThisWorkbook.Sheets(3).Cells(4, 8).Value
.Offset(5, 4).Value = ThisWorkbook.Sheets(3).Cells(4, 9).Value
.Offset(5, 7).Value = ThisWorkbook.Sheets(3).Cells(4, 10).Value
.Offset(6, 0).Value = ThisWorkbook.Sheets(3).Cells(5, 7).Value
.Offset(6, 2).Value = ThisWorkbook.Sheets(3).Cells(5, 8).Value
.Offset(6, 4).Value = ThisWorkbook.Sheets(3).Cells(5, 9).Value
.Offset(6, 7).Value = ThisWorkbook.Sheets(3).Cells(5, 10).Value
End With

You can try to disable screenupdating during execution.
Disable ScreenUpdating
To disable ScreenUpdating, at the beginning of your code put this line:
Application.ScreenUpdating = False
Enable ScreenUpdating
To re-enable ScreenUpdating, at the end of your code put this line:
Application.ScreenUpdating = True

Related

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.

Add row to top of table after headers

I want to add new data to a table with a form. I have it adding data at the bottom of the sheet.
I want the new info at the top.
With my code, it sends the data to two sheets, the "home" sheet and the sheet that is selected in the first combo box.
Private Sub CommandButton1_Click()
TargetSheet = ComboBox1.Value
If TargetSheet = "" Then
Exit Sub
End If
Worksheets(TargetSheet).Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(lastrow + 1, 1).Value = TextBox1.Value
ActiveSheet.Cells(lastrow + 1, 2).Value = TextBox2.Value
ActiveSheet.Cells(lastrow + 1, 3).Value = TextBox3.Value
ActiveSheet.Cells(lastrow + 1, 4).Value = TextBox4.Value
ActiveSheet.Cells(lastrow + 1, 5).Value = TextBox5.Value
ActiveSheet.Cells(lastrow + 1, 6).Value = TextBox6.Value
ActiveSheet.Cells(lastrow + 1, 7).Value = TextBox7.Value
ActiveSheet.Cells(lastrow + 1, 8).Value = TextBox8.Value
Worksheets("Home").Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(lastrow + 1, 1).Value = ComboBox1.Value
ActiveSheet.Cells(lastrow + 1, 2).Value = TextBox1.Value
ActiveSheet.Cells(lastrow + 1, 3).Value = TextBox2.Value
ActiveSheet.Cells(lastrow + 1, 4).Value = TextBox3.Value
ActiveSheet.Cells(lastrow + 1, 5).Value = TextBox4.Value
ActiveSheet.Cells(lastrow + 1, 6).Value = TextBox5.Value
ActiveSheet.Cells(lastrow + 1, 7).Value = TextBox6.Value
ActiveSheet.Cells(lastrow + 1, 8).Value = TextBox7.Value
ActiveSheet.Cells(lastrow + 1, 9).Value = TextBox8.Value
ActiveSheet.Cells(lastrow + 1, 10).Value = Date
ActiveSheet.Cells(lastrow + 1, 11).Value = TimeValue(Now)
ActiveSheet.Cells(lastrow + 1, 12).Value = TextBox9.Value
MsgBox ("Item Added Successfully.")
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
Worksheets("Home").Activate
Worksheets("Home").Cells(1, 1).Select
End Sub
How do I put the new data in the second row since I have headers on the sheet?
There are a lot of stuff to improve your my code, but I want to keep it simple
Some things to begin:
Use option explicit so you don't have unexpected behavior with undefined variables
Always indent your code (see www.rubberduckvba.com a free tool that helps you with that)
Try to separate your logic defining variables and the reusing them
Name your forms' controls
Check a great article about UserForms (when you feel you're ready to advance)
Check the code's comments, and adapt it to fit your needs
EDIT: No need for the EntireRow qualifier as we are already selecting the whole row, and added the copy format from below
Code:
Private Sub CommandButton1_Click()
' Define object variables
Dim targetSheet As Worksheet
Dim homeSheet As Worksheet
Dim targetSheetName As String
Dim homeSheetName As String
Dim targetSheetTopRow As Long
Dim homeSheetTopRow As Long
Dim textBox1Value As Variant
Dim textBox2Value As Variant
Dim textBox3Value As Variant
Dim textBox4Value As Variant
Dim textBox5Value As Variant
Dim textBox6Value As Variant
Dim textBox7Value As Variant
Dim textBox8Value As Variant
Dim textBox9Value As Variant
' Define parameters
targetSheetTopRow = 2
homeSheetTopRow = 2
homeSheetName = "Home"
' Validate if combobox has any value
If Me.ComboBox1.Value = vbNullString Then Exit Sub
' Get target sheet name
targetSheetName = Me.ComboBox1.Value
' Add a reference to sheets
Set targetSheet = ThisWorkbook.Worksheets(targetSheetName)
Set homeSheet = ThisWorkbook.Worksheets(homeSheetName)
' Store current controls values
textBox1Value = Me.TextBox1.Value
textBox2Value = Me.TextBox2.Value
textBox3Value = Me.TextBox3.Value
textBox4Value = Me.TextBox4.Value
textBox5Value = Me.TextBox5.Value
textBox6Value = Me.TextBox6.Value
textBox7Value = Me.TextBox7.Value
textBox8Value = Me.TextBox8.Value
' No need to activate stuff
With targetSheet
' Insert a row after row 2
.Range(targetSheetTopRow & ":" & targetSheetTopRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
' Add cells values
.Cells(targetSheetTopRow, 1).Value = textBox1Value
.Cells(targetSheetTopRow, 2).Value = textBox2Value
.Cells(targetSheetTopRow, 3).Value = textBox3Value
.Cells(targetSheetTopRow, 4).Value = textBox4Value
.Cells(targetSheetTopRow, 5).Value = textBox5Value
.Cells(targetSheetTopRow, 6).Value = textBox6Value
.Cells(targetSheetTopRow, 7).Value = textBox7Value
.Cells(targetSheetTopRow, 8).Value = textBox8Value
End With
With homeSheet
' Insert a row after row 2
.Range(homeSheetTopRow & ":" & homeSheetTopRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
' Add cells values
.Cells(homeSheetTopRow, 1).Value = textBox1Value
.Cells(homeSheetTopRow, 2).Value = textBox2Value
.Cells(homeSheetTopRow, 3).Value = textBox3Value
.Cells(homeSheetTopRow, 4).Value = textBox4Value
.Cells(homeSheetTopRow, 5).Value = textBox5Value
.Cells(homeSheetTopRow, 6).Value = textBox6Value
.Cells(homeSheetTopRow, 7).Value = textBox7Value
.Cells(homeSheetTopRow, 8).Value = textBox8Value
.Cells(homeSheetTopRow, 9).Value = Date
.Cells(homeSheetTopRow, 10).Value = TimeValue(Now)
.Cells(homeSheetTopRow, 11).Value = textBox9Value
End With
' Clear control's values
Me.TextBox1.Value = vbNullString
Me.TextBox2.Value = vbNullString
Me.TextBox3.Value = vbNullString
Me.TextBox4.Value = vbNullString
' Alert user
MsgBox ("Item Added Successfully.")
' Goto...
homeSheet.Activate
homeSheet.Cells(1, 1).Select
End Sub
Let me know if it works or you need more help

How to loop through (and copy) the same data based on number of listbox entries

I have a userform for an equipment loan checkout which I am trying to make function for multiple items when needed. Essentially, the code below is written so that all the relevant information is correctly transferred to the appropriate sheet, however it only copies the last selected listbox entry.
As I am still quite new to coding in general, I need some help with the loop to do this. But, it seems even more complicated to me, because I want the the date value, name value, return date value, and induction (yes/no) value all copied multiple times into each new table entry - which, is obviously for each item in the list box.
(disregard the mysentence public function at the end).
Any help would be appreciated, thanks!
Private Sub cmdCheckout_Click()
Dim mysentence As String
Dim ws As Worksheet
Dim i As Integer
Dim table_list_object As ListObject
Dim table_object_row As ListRow
Dim fnd As Variant
Set ws = Worksheets("Loans")
Set ws2 = Worksheets("MajorInventoryList")
Set table_list_object = ws.ListObjects(1)
Set table_object_row = table_list_object.ListRows.Add
Set fnd = ws2.Range("A:A").Find(Me.ItemList.Column(0, i))
For i = 0 To Me.ItemList.ListCount - 1
If Me.ItemList.Selected(i) = True Then
table_object_row.Range(1, 1).Value = DateValue(Format(Me.txtdate.Value, "dd/mm/yy"))
table_object_row.Range(1, 2).Value = Me.cboName.Value
table_object_row.Range(1, 3).Value = Me.ItemList.Column(1, i)
table_object_row.Range(1, 6).Value = Me.ItemList.Column(2, i)
table_object_row.Range(1, 8).Value = Me.txtLocation.Value
table_object_row.Range(1, 9).Value = DateValue(Format(Me.txtReturn.Value, "dd/mm/yy"))
table_object_row.Range(1, 10).Value = Me.cboInduct.Value
table_object_row.Range(1, 12).Value = Me.ItemList.Column(0, i)
If Not fnd Is Nothing Then
table_object_row.Range(1, 4).Value = fnd.Offset(0, 3).Value
table_object_row.Range(1, 5).Value = fnd.Offset(0, 4).Value
table_object_row.Range(1, 7).Value = fnd.Offset(0, 7).Value
End If
End If
Next
mysentence = UpdateAvailability(Me.ItemList)
End Sub
Give this a shot. See comments for notes on my modifications.
Option Explicit
Private Sub cmdCheckout_Click()
Dim mysentence As String
Dim ws As Worksheet
Dim i As Integer
Dim table_list_object As ListObject
Dim table_object_row As ListRow
Dim fnd As Variant
Set ws = Worksheets("Loans")
Set ws2 = Worksheets("MajorInventoryList")
Set table_list_object = ws.ListObjects(1)
For i = 0 To Me.ItemList.ListCount - 1
If Me.ItemList.Selected(i) = True Then
Set table_object_row = table_list_object.ListRows.Add '~~~ Moved this inside loop since you only want to add a row if the list item is selected
Set fnd = ws2.Range("A:A").Find(Me.ItemList.Column(0, i)) '~~~ and only want to find if item is selected
With table_object_row '~~~ with block speeds up processing and easier to read
.Range(1, 1).Value = DateValue(Format(Me.txtdate.Value, "dd/mm/yy"))
.Range(1, 2).Value = Me.cboName.Value
.Range(1, 3).Value = Me.ItemList.Column(1, i)
.Range(1, 6).Value = Me.ItemList.Column(2, i)
.Range(1, 8).Value = Me.txtLocation.Value
.Range(1, 9).Value = DateValue(Format(Me.txtReturn.Value, "dd/mm/yy"))
.Range(1, 10).Value = Me.cboInduct.Value
.Range(1, 12).Value = Me.ItemList.Column(0, i)
If Not fnd Is Nothing Then
.Range(1, 4).Value = fnd.Offset(0, 3).Value
.Range(1, 5).Value = fnd.Offset(0, 4).Value
.Range(1, 7).Value = fnd.Offset(0, 7).Value
End If
End With
End If
Next
mysentence = UpdateAvailability(Me.ItemList)
End Sub

Excel VBA Userform: data overwrites when I change first column of data entry

I am using the following code to enter data from Userform to Excel sheet and works fine.
The problem is that it overwrites the same row of data. But if I change:
.Cells(RowCount, 4).Value = Me.DepSectDrop.Value to contain a 1 --> .Cells(RowCount, 1).Value = Me.DepSectDrop.Value, and likewise for the rest (2 fore SiteFacOpen, 3 for CaseStartOpen, etc), it does not overwrite.
Private Sub cmdAdd_Click()
'Copy input values to sheet.
Dim RowCount As Long
Dim ws As Worksheet
Set ws = Worksheets("TRACK")
RowCount = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With ws
.Cells(RowCount, 4).Value = Me.DepSectDrop.Value
.Cells(RowCount, 5).Value = Me.SiteFacOpen.Value
.Cells(RowCount, 6).Value = Me.CaseStartOpen.Value
.Cells(RowCount, 7).Value = Me.TypeDrop.Value
.Cells(RowCount, 8).Value = Me.ProcessDrop.Value
.Cells(RowCount, 9).Value = Me.CompNameOpen.Value
.Cells(RowCount, 10).Value = Me.CompEIDOpen.Value
.Cells(RowCount, 11).Value = Me.RespNameOpen.Value
.Cells(RowCount, 12).Value = Me.RespEIDOpen.Value
.Cells(RowCount, 13).Value = Me.DescOpen.Value
End With
'Clear input controls.
Me.DepSectDrop.Value = ""
Me.SiteFacOpen.Value = ""
Me.CaseStartOpen.Value = ""
Me.TypeDrop.Value = ""
Me.ProcessDrop.Value = ""
Me.CompNameOpen.Value = ""
Me.CompEIDOpen.Value = ""
Me.RespNameOpen.Value = ""
Me.RespEIDOpen.Value = ""
Me.DescOpen.Value = ""
End Sub
What do I need to do to so I maintain the right columns for it all to be entered, but not be overwritten? Thank you
You need to change all lines that start
.Cells(RowCount, 5).Value ...
To
.Cells(RowCount + 1, 5).Value
The '+1' bit means you're using the next blank line.
Also, as Samuel pointed out, you should also change to
RowCount = ws.Cells (Rows.Count, 4).End (xlUp).Offset (1,0).Row
so that you're testing a column that's guaranteed to have data in it!
Sorry, I missed the offset bit ... No need to '+1' if you're offsetting by 1 ... It amounts to the same thing.

Matching pairs of cells while iterating through columns to then return a new pair of cells

I am trying to write a code that will take one cell and then iterate through another column to find a match, once it has found a match it will then match two other cells in that same row and return the value of a 5th and 6th cell. However, it is not working! any suggestions??
Sub rates()
Dim i As Integer
For i = 2 To 2187
If Cells(i, 1).Value = Cells(i, 11).Value Then
If Cells(i, 2).Value = Cells(i, 12).Value Then
Cells(i, 20) = Cells(i, 1).Value
Cells(i, 21) = Cells(i, 11).Value
Cells(i, 22) = Cells(i, 4).Value
Cells(i, 23) = Cells(i, 16).Value
Else
Cells(i, 24) = "No match"
End If
End If
Next i
End Sub
Try fully qualifying your cell objects i.e. sheet1.cells(i,1).value etc or encase within a with statement i.e.
with sheet1
if .cells(i,X) = .cells(i,Y) then
'...etc
end with
I think the default property for a range is "Value" but try putting .Value on to the end of all those Cell lines too... like you have for half of them :)
[EDIT/Addition:]
... failing that, you're not actually searching a whole column at any point: try something like:
Sub rates()
Dim i As Integer
Dim rgSearch As Range
Dim rgMatch As Range
Dim stAddress As String
Dim blMatch As Boolean
With wsSheet
Set rgSearch = .Range(.Cells(x1, y1), .Cells(x2, y2)) ' Replace where appropriate (y = 1 or 11 i guess, x = start and end row)
End With
For i = 2 To 2187
Set rgMatch = rgSearch.Find(wsSheet.Cells(i, y)) ' y = 1 or 11 (opposite of above!)
blMatch = False
If Not rgMatch Is Nothing Then
stAddress = rgMatch.Address
Do Until rgMatch Is Nothing Or rgMatch.Address = stAddress
If rgMatch.Offset(0, y).Value = Cells(i, 12).Value Then
Cells(i, 20) = Cells(i, 1).Value
Cells(i, 21) = Cells(i, 11).Value
Cells(i, 22) = Cells(i, 4).Value
Cells(i, 23) = Cells(i, 16).Value
blMatch = True
Else
End If
Set rgMatch = rgSearch.FindNext(rgMatch)
Loop
End If
If Not blMatch Then
Cells(i, 24) = "No match"
End If
Next i
End Sub
I've made a lot of assumptions in there and there's a few variables you'll have to replace. You could also probably use application.worksheetfunction.match but .find is quicker and more awesome

Resources