Hi,
I have 8 text boxes, 4 combo boxes and 3 list boxes on a userform along with a textbox which automatically generates a new Test Request Number (TRN).
The multi select listbox called TestsRequired contains a list of tests which the user selects from. This is dropped in to column M on the next empty row.
When I press the command button (OK) at the bottom of the form, this drops all of these boxes on to the next empty row in the form.
It then copies columns A to J down depending on the number of tests inputted in to column M.
The issue I am having is that the transfer of data when pressing OK is taking forever to load.
Sheet1.Activate
Dim emptyrow As Long
emptyrow = Cells(Rows.Count, "A").End(xlUp).Row + 1
Cells(emptyrow, 1).Value = TRNNumber.Value
Cells(emptyrow, 2).Value = DateRequested.Value
Cells(emptyrow, 3).Value = TestHouse.Value
Cells(emptyrow, 4).Value = ProductName.Value
Cells(emptyrow, 5).Value = Shade.Value
Cells(emptyrow, 6).Value = POFabric.Value
Cells(emptyrow, 7).Value = Supplier.Value
Cells(emptyrow, 8).Value = TestRequestedBy.Value
Cells(emptyrow, 9).Value = TestAuthorisedBy.Value
Cells(emptyrow, 10).Value = GLCode.Value
Cells(emptyrow, 14).Value = Other.Value
Cells(emptyrow, 14).Value = Other2.Value
Cells(emptyrow, 21).Value = Ironing.Value
For i = 0 To TestsRequired.ListCount - 1
If TestsRequired.Selected(i) Then
Range("M" & Rows.Count).End(xlUp).Offset(1).Value = TestsRequired.List(i)
End If
Next i
For i = 0 To Washing.ListCount - 1
If Washing.Selected(i) Then
Range("T" & Rows.Count).End(xlUp).Offset(1).Value = Washing.List(i)
End If
Next i
For i = 0 To Drying.ListCount - 1
If Drying.Selected(i) Then
Range("U" & Rows.Count).End(xlUp).Offset(1).Value = Drying.List(i)
End If
Next i
For Each area In Columns("A:J").SpecialCells(xlCellTypeBlanks)
If area.Cells.Row <= ActiveSheet.UsedRange.Rows.Count Then
area.Cells = Range(area.Address).Offset(-1, 0).Value
End If
Next area
Does anyone have any ideas how I can make this quicker?
Thank you so much for your help.
Hi Helen,
Nothing in the code jumps out at me but I don't know what values the various ListCounts take. If they are very large for some reason that could slow things.
I'd need to see your workbook/code/form to check anything else.
Regards
Phil
The first thing that comes to mind is to change the data tables to arrays. This almost always gives speed increases of ten to a hundred times faster.
Warren is right, but:
For Each area In Columns("A:J").SpecialCells(xlCellTypeBlanks)
If area.Cells.Row <= ActiveSheet.UsedRange.Rows.Count Then
area.Cells = Range(area.Address).Offset(-1, 0).Value
End If
Next area
Why are you evaluating 10 full columns - A:J, with 1 million+ rows each? There can be a lot of blank cells.
I don't understand what's the purpose of this code, so you need to clarify things.
Hi All,
Thank you very much for replying so quickly.
The reason for copying the code down is I have a multi page userform which has some tabs which refer to the data stored in columns A to J. When I add values from the listbox TestsRequired in to column M, I only need to copy columns A to J for the number of rows I have added in to column M but as I am still learning VBA I do not know how to do this.
I have attached the file to this reply to see if anyone can work out why it is so slow.
Thank you very much.
You have 2 options:
Put an exit if you have exceeded the used range, so your code will not examine 10+million cells:
If area.Cells.Row <= ActiveSheet.UsedRange.Rows.Count Then
area.Cells = Range(area.Address).Offset(-1, 0).Value
Else
exit for
End If
Next area
Or, put repeatable code into a separate procedure and call it from the main procedure:
Dim wks As Worksheet: Set wks = ThisWorkbook.Worksheets("Sheet1")
For i = 0 To TestsRequired.ListCount - 1
If TestsRequired.Selected(i) Then
FillAJData wks, "M", TestsRequired.List(i)
End If
Next i
For i = 0 To Washing.ListCount - 1
If Washing.Selected(i) Then
FillAJData wks, "T", Washing.List(i)
End If
Next i
For i = 0 To Drying.ListCount - 1
If Drying.Selected(i) Then
FillAJData wks, "U", Drying.List(i)
End If
Next i
Set wks = Nothing
End Sub
Sub FillAJData(ByVal wks As Worksheet, ByVal rng As String, RngValue As String)
Dim emptyrow As Long
With wks
emptyrow = .Cells.Find("*", .Cells(1), , , xlByRows, xlPrevious).Row + 1
.Cells(emptyrow, 1).Value = TRNNumber.Value
.Cells(emptyrow, 2).Value = DateRequested.Value
.Cells(emptyrow, 3).Value = TestHouse.Value
.Cells(emptyrow, 4).Value = ProductName.Value
.Cells(emptyrow, 5).Value = Shade.Value
.Cells(emptyrow, 6).Value = POFabric.Value
.Cells(emptyrow, 7).Value = Supplier.Value
.Cells(emptyrow, 8).Value = TestRequestedBy.Value
.Cells(emptyrow, 9).Value = TestAuthorisedBy.Value
.Cells(emptyrow, 10).Value = GLCode.Value
.Cells(emptyrow, 14).Value = Other.Value
.Cells(emptyrow, 14).Value = Other2.Value
.Cells(emptyrow, 21).Value = Ironing.Value
.Cells(emptyrow, rng).Value = RngValue
End With
End Sub
Thank you for the 2 options.
I prefer the 2nd option as if someone does not add something in to one of the textboxes from columns A to J then it does not copy these down.
However, this is still taking approx. 15 seconds to add 3 lines of data. Is this usual? Just seems to take longer than I am used to from any code I have done before.
Sorry for this just would like to understand if there is anything I can do about it.
I think it's related to the structure of your file, if you have many formulas and calculation is automatic, things are slow.
You can disable calculation from code with:
application.Calculation=xlCalculationManual
After the code finishes writing data, turn back to automatic:
application.Calculation=xlCalculationAutomatic
Or, as Warren suggested, you can collect the data into an array and drop the array into cells in one action instead of writing cell by cell.
Thank you very much - I will try this 🙂
How would I structure an Array? Do you maybe have a link to somewhere I could use?
I have never done one before so not sure how to write the code for it.
Thanks again for your help.
If you disable calculation, the transfer to sheet will be almost instant, in less than 1 second.
Because you have just a few rows to add, what you have already should be enough, an array is best for larger data sets.
Here is an example of collecting data into an array and transfer to sheet.
Note that the transfer is instant if you disable calculation manually before running the form (Formulas tab in ribbon>Calculation>Manual), in both versions (array or non array method)
What takes a few seconds is disabling and enabling calculation from code, not data transfer.
Private Sub OK_Click()
Dim wks As Worksheet: Set wks = ThisWorkbook.Worksheets("Sheet1")
Dim Arr() As Variant, Counter As Long
Counter = 1
For i = 0 To TestsRequired.ListCount - 1
If TestsRequired.Selected(i) Then FillAJData Arr, Counter, 13, TestsRequired.List(i)
Next i
For i = 0 To Washing.ListCount - 1
If Washing.Selected(i) Then FillAJData Arr, Counter, 20, Washing.List(i)
Next i
For i = 0 To Drying.ListCount - 1
If Drying.Selected(i) Then FillAJData Arr, Counter, 21, Drying.List(i)
Next i
Dim emptyrow As Long
emptyrow = wks.Cells.Find("*", wks.Cells(1), , , xlByRows, xlPrevious).Row + 1
'array is filled, transpose and fill to sheet
'Application.Calculation = xlCalculationManual
wks.Cells(emptyrow, 1).Resize(UBound(Arr, 2), UBound(Arr, 1)).Value = TransposeArray(Arr)
'Application.Calculation = xlCalculationAutomatic
Set wks = Nothing
Unload Me
End Sub
Public Function TransposeArray(myarray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long
Dim Yupper As Long
Dim tempArray As Variant
Xupper = UBound(myarray, 2)
Yupper = UBound(myarray, 1)
ReDim tempArray(LBound(myarray, 2) To Xupper, LBound(myarray, 1) To Yupper)
For X = LBound(myarray, 2) To Xupper
For Y = LBound(myarray, 1) To Yupper
tempArray(X, Y) = myarray(Y, X)
Next Y
Next X
TransposeArray = tempArray
End Function
Sub FillAJData(ByRef Arr As Variant, ByRef Counter As Long, ByVal Col As Byte, RngValue As String)
ReDim Preserve Arr(1 To 21, 1 To Counter)
Arr(1, Counter) = TRNNumber.Value
Arr(2, Counter) = DateRequested.Value
Arr(3, Counter) = TestHouse.Value
Arr(4, Counter) = ProductName.Value
Arr(5, Counter) = Shade.Value
Arr(6, Counter) = POFabric.Value
Arr(7, Counter) = Supplier.Value
Arr(8, Counter) = TestRequestedBy.Value
Arr(9, Counter) = TestAuthorisedBy.Value
Arr(10, Counter) = GLCode.Value
Arr(14, Counter) = Other.Value
Arr(14, Counter) = Other2.Value
Arr(21, Counter) = Ironing.Value
Arr(Col, Counter) = RngValue
Counter = Counter + 1
End Sub
You also have to review what you are doing with that form data, some values are written in the same place without any sense (to me at least):
Cells(emptyrow, 14).Value = Other.Value
Cells(emptyrow, 14).Value = Other2.Value
Cells(emptyrow, 21).Value = Ironing.Value
Range("U" & Rows.Count).End(xlUp).Offset(1).Value = Drying.List(i)
In column 14, you are sending 2 values, obviously only the last one will remain.
In column 21, which is column "U", you are sending once the Ironing value, which will be overwritten by Drying value, if any.
That is brilliant thank you - Will give the array code a try once the forms are completed.
The Other and Other 2 should be based on what has been selected in the Listbox but not sure if I have done the code for that correctly. So the Other box only shows when Martindale is selected from the TestsRequested listbox and Other 2 only shows when Other (please specify) is selected from the TestsRequested listbox.
The ironing and drying is a typo - thank you for pointing it out! Will have to get that fixed!
