User form very slow to transfer data to worksheet

Hi,
I've created a userform for data entry from a questionnaire. There is a save button which transfers all the information to the worksheet but this takes over 30 seconds to complete. I've tried to fiddle with suppressing events using EnableEvents but it does't help. I'm not sure what to do so any help would be really appreciated! Bellow is the whole userform code, most of the data transfer comes from checkboxes from 18 questions (I named them CB1E/G/A/P for excellent good average poor etc.)

Public EnableEvents As Boolean

Private Sub CancelButton_Click()
Unload Me
End Sub

Private Sub ClearButton_Click()
Call UserForm_Initialize
End Sub

Private Sub SaveButton_Click()

Dim emptyRow As Long

'Make Sheet1 active
Sheet1.Activate

'Determine emptyRow
emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1

'Transfer information
If Not EnableEvents Then Exit Sub

Me.EnableEvents = False
If CB1E.Value = True Then Cells(emptyRow, 1).Value = "4"
If CB1G.Value = True Then Cells(emptyRow, 1).Value = "3"
If CB1A.Value = True Then Cells(emptyRow, 1).Value = "2"
If CB1P.Value = True Then Cells(emptyRow, 1).Value = "1"
If CB2E.Value = True Then Cells(emptyRow, 2).Value = "4"
If CB2G.Value = True Then Cells(emptyRow, 2).Value = "3"
If CB2A.Value = True Then Cells(emptyRow, 2).Value = "2"
If CB2P.Value = True Then Cells(emptyRow, 2).Value = "1"
If CB3E.Value = True Then Cells(emptyRow, 3).Value = "4"
If CB3G.Value = True Then Cells(emptyRow, 3).Value = "3"
If CB3A.Value = True Then Cells(emptyRow, 3).Value = "2"
If CB3P.Value = True Then Cells(emptyRow, 3).Value = "1"
If CB4E.Value = True Then Cells(emptyRow, 4).Value = "4"
If CB4G.Value = True Then Cells(emptyRow, 4).Value = "3"
If CB4A.Value = True Then Cells(emptyRow, 4).Value = "2"
If CB4P.Value = True Then Cells(emptyRow, 4).Value = "1"
If CB5E.Value = True Then Cells(emptyRow, 5).Value = "4"
If CB5G.Value = True Then Cells(emptyRow, 5).Value = "3"
If CB5A.Value = True Then Cells(emptyRow, 5).Value = "2"
If CB5P.Value = True Then Cells(emptyRow, 5).Value = "1"
If CB6E.Value = True Then Cells(emptyRow, 6).Value = "4"
If CB6G.Value = True Then Cells(emptyRow, 6).Value = "3"
If CB6A.Value = True Then Cells(emptyRow, 6).Value = "2"
If CB6P.Value = True Then Cells(emptyRow, 6).Value = "1"
If CB7E.Value = True Then Cells(emptyRow, 7).Value = "4"
If CB7G.Value = True Then Cells(emptyRow, 7).Value = "3"
If CB7A.Value = True Then Cells(emptyRow, 7).Value = "2"
If CB7P.Value = True Then Cells(emptyRow, 7).Value = "1"
If CB8E.Value = True Then Cells(emptyRow, 8).Value = "4"
If CB8G.Value = True Then Cells(emptyRow, 8).Value = "3"
If CB8A.Value = True Then Cells(emptyRow, 8).Value = "2"
If CB8P.Value = True Then Cells(emptyRow, 8).Value = "1"
If CB9E.Value = True Then Cells(emptyRow, 9).Value = "4"
If CB9G.Value = True Then Cells(emptyRow, 9).Value = "3"
If CB9A.Value = True Then Cells(emptyRow, 9).Value = "2"
If CB9P.Value = True Then Cells(emptyRow, 9).Value = "1"
If CB10E.Value = True Then Cells(emptyRow, 10).Value = "4"
If CB10G.Value = True Then Cells(emptyRow, 10).Value = "3"
If CB10A.Value = True Then Cells(emptyRow, 10).Value = "2"
If CB10P.Value = True Then Cells(emptyRow, 10).Value = "1"
If CB11E.Value = True Then Cells(emptyRow, 11).Value = "4"
If CB11G.Value = True Then Cells(emptyRow, 11).Value = "3"
If CB11A.Value = True Then Cells(emptyRow, 11).Value = "2"
If CB11P.Value = True Then Cells(emptyRow, 11).Value = "1"
If CB12E.Value = True Then Cells(emptyRow, 12).Value = "4"
If CB12G.Value = True Then Cells(emptyRow, 12).Value = "3"
If CB12A.Value = True Then Cells(emptyRow, 12).Value = "2"
If CB12P.Value = True Then Cells(emptyRow, 12).Value = "1"
If CB13E.Value = True Then Cells(emptyRow, 13).Value = "4"
If CB13G.Value = True Then Cells(emptyRow, 13).Value = "3"
If CB13A.Value = True Then Cells(emptyRow, 13).Value = "2"
If CB13P.Value = True Then Cells(emptyRow, 13).Value = "1"
If CB14E.Value = True Then Cells(emptyRow, 14).Value = "4"
If CB14G.Value = True Then Cells(emptyRow, 14).Value = "3"
If CB14A.Value = True Then Cells(emptyRow, 14).Value = "2"
If CB14P.Value = True Then Cells(emptyRow, 14).Value = "1"
If CB15E.Value = True Then Cells(emptyRow, 15).Value = "4"
If CB15G.Value = True Then Cells(emptyRow, 15).Value = "3"
If CB15A.Value = True Then Cells(emptyRow, 15).Value = "2"
If CB15P.Value = True Then Cells(emptyRow, 15).Value = "1"
If CB16E.Value = True Then Cells(emptyRow, 16).Value = "4"
If CB16G.Value = True Then Cells(emptyRow, 16).Value = "3"
If CB16A.Value = True Then Cells(emptyRow, 16).Value = "2"
If CB16P.Value = True Then Cells(emptyRow, 16).Value = "1"
If CB17E.Value = True Then Cells(emptyRow, 17).Value = "4"
If CB17G.Value = True Then Cells(emptyRow, 17).Value = "3"
If CB17A.Value = True Then Cells(emptyRow, 17).Value = "2"
If CB17P.Value = True Then Cells(emptyRow, 17).Value = "1"
If CBYES.Value = True Then Cells(emptyRow, 18).Value = "Y"
If CBNO.Value = True Then Cells(emptyRow, 18).Value = "N"

Cells(emptyRow, 19).Value = CBmonth.Value
Cells(emptyRow, 20).Value = TByear.Value
Me.EnableEvents = True

Call UserForm_Initialize
End Sub

Private Sub TByear_Enter()
If Not EnableEvents Then Exit Sub
Me.EnableEvents = False
TByear.Value = ""
Me.EnableEvents = True
End Sub
Private Sub UserForm_Initialize()

Me.EnableEvents = True

'Clear tickboxes'
Dim ctrl As Control
For Each ctrl In Me.Controls
If TypeName(ctrl) = "CheckBox" Then ctrl.Value = False
Next

'Fill CBmonth'
With Me.CBmonth
.AddItem "January"
.AddItem "February"
.AddItem "March"
.AddItem "April"
.AddItem "May"
.AddItem "June"
.AddItem "July"
.AddItem "August"
.AddItem "September"
.AddItem "October"
.AddItem "November"
.AddItem "December"
.AddItem "Select Month"
End With

CBmonth.ListIndex = 12

'Clear year'
TByear.Value = "yyyy"

End Sub

Hi Tom,
Thanks for the quick reply. I just tried this but I hasn't made any difference.

can you post the Workbook?
that would make things easier.

and put your Code in the first poste in Code Tags.
Just Mark your Code and click the # button

Greets
Loki

QUESTIONNAIRE.xlsm
There is some data that i've just been adding to test the workbook.

Please Login or Register  to view this content.

Finally! Thank you so much!

I was just having the same issues with my user form. Your solution worked for me as well!

Thanks (almost 7 years later) lol

On second note it has prevented my pivot table from automatically refreshing.

If you are still around or anyone here can help could you have a quick look maybe we can adjust something small. It seems the ScreenUpdating = False is what is stopping the pivot table from refreshing.


Private Sub buylong4_Click()

'General Variables
Dim numRows As Long
numRows = Range(Selection.ListObject.Name).Rows.Count

Dim firstRow As Long
firstRow = Range(Selection.ListObject.Name).Row

Dim tableName As String
tableName = Selection.ListObject.Name

Set tbl = ActiveSheet.ListObjects(tableName)

Dim x As Long

'Speeds up User Form
ScreenUpdating = False
Application.Calculation = xlCalculationManual

'-----------------------------------------------------------------------------------------------------------------
Dim currentRow As Long
currentRow = firstRow - 1

For x = 1 To tbl.Range.Rows.Count

If WorksheetFunction.CountA(tbl.Range.Rows(x)) = 0 Then

'Add the values to the table
Worksheets("Trade Tape").Cells(currentRow, 4).Value = Now
Worksheets("Trade Tape").Cells(currentRow, 5).Value = Date
Worksheets("Trade Tape").Cells(currentRow, 6).Value = Ticker4.Value
Worksheets("Trade Tape").Cells(currentRow, 7).Value = Qty4.Value
Worksheets("Trade Tape").Cells(currentRow, 8).Value = "LONG"
Worksheets("Trade Tape").Cells(currentRow, 9).Value = entryprice4.Value
Worksheets("Trade Tape").Cells(currentRow, 10).Value = exitprice4.Value
Worksheets("Trade Tape").Cells(currentRow, 11).Value = maxdrawdownprice4.Value
Worksheets("Trade Tape").Cells(currentRow, 12).Value = maxdrawupprice4.Value
'Change Price of trading fees here!!!
Worksheets("Trade Tape").Cells(currentRow, 13).Value = 4.95 * 2
Worksheets("Trade Tape").Cells(currentRow, 19).Value = Setupstyle4.Value
Worksheets("Trade Tape").Cells(currentRow, 20).Value = rvalue4.Value

Application.ScreenUpdating = True
Unload Me
Exit Sub

End If

currentRow = currentRow + 1

Next x

Dim endRow As Long
endRow = firstRow + numRows


'Find last row of table and adds a new row + resizes the table
Cells(endRow, 1).EntireRow.Insert

With tbl.Range
tbl.Resize .Resize(.CurrentRegion.Rows.Count)
End With

'Add the values to the table
Worksheets("Trade Tape").Cells(endRow, 4).Value = Now
Worksheets("Trade Tape").Cells(endRow, 5).Value = Date
Worksheets("Trade Tape").Cells(endRow, 6).Value = Ticker4.Value
Worksheets("Trade Tape").Cells(endRow, 7).Value = Qty4.Value
Worksheets("Trade Tape").Cells(endRow, 8).Value = "LONG"
Worksheets("Trade Tape").Cells(endRow, 9).Value = entryprice4.Value
Worksheets("Trade Tape").Cells(endRow, 10).Value = exitprice4.Value
Worksheets("Trade Tape").Cells(endRow, 11).Value = maxdrawdownprice4.Value
Worksheets("Trade Tape").Cells(endRow, 12).Value = maxdrawupprice4.Value
'Change Price of trading fees here!!!
Worksheets("Trade Tape").Cells(endRow, 13).Value = 4.95 * 2
Worksheets("Trade Tape").Cells(endRow, 19).Value = Setupstyle4.Value
Worksheets("Trade Tape").Cells(endRow, 20).Value = rvalue4.Value

'------------INDICATES WHETHER STRATEGY WAS USED OR NOT------------

If CheckBox1.Value = True Then
Worksheets("Trade Tape").Cells(endRow, 18).Value = "Yes"
End If

If CheckBox1.Value = False Then
Worksheets("Trade Tape").Cells(endRow, 18).Value = "No"
End If

Application.ScreenUpdating = True

Sort
Unload Me

'Speeds up User Form (Continued)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub