PDA

View Full Version : Speed Up Get Data Code



Loss1003
02-29-2016, 12:32 PM
I've got an excel sheet and userform1 that stores up to approx 100 columns of data. The speed was working fine up until approx 4,000 rows of data are entered. The form then takes quadruple the time to load, retrieving data, moving to the next row, saving, deleting. etc.

Perhaps someone can share a few pointers on how to speed the following Get Data code up.




With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

Dim R As Long

lastrow = FindLastRow + 1

If IsNumeric(RowNumber.Text) Then
R = CLng(RowNumber.Text)

Else
Cleardata
MsgBox "Illegal Row Number"
Exit Sub

End If

If Sheet2.Cells(R, 25).Value = "X" Then
General.Value = True
End If
If Sheet2.Cells(R, 26).Value = "X" Then
Onsite.Value = True
End If
If Sheet2.Cells(R, 27).Value = "X" Then
Phone.Value = True
End If
If Sheet2.Cells(R, 28).Value = "X" Then
Desktop.Value = True
End If
If Sheet2.Cells(R, 29).Value = "X" Then
Switch1.Value = True
End If
If Sheet2.Cells(R, 30).Value = "X" Then
Unprod.Value = True
End If
If Sheet2.Cells(R, 31).Value = "X" Then
Canreq.Value = True
End If
If Sheet2.Cells(R, 32).Value = "X" Then
Canlc.Value = True
End If
If Sheet2.Cells(R, 33).Value = "X" Then
Reassign.Value = True
End If
If Sheet2.Cells(R, 34).Value = "X" Then
Otherscope.Value = True
OtherscopeN.Visible = True
End If

If Sheet2.Cells(R, 52).Value = "X" Then
QQip.Value = True
QQc.Value = False
End If

If Sheet2.Cells(R, 53).Value = "X" Then
QQip.Value = False
QQc.Value = True
End If

If Sheet2.Cells(R, 52).Value = "" And Sheet2.Cells(R, 53).Value = "" Then
QQip.Value = False
QQc.Value = False
End If

If Sheet2.Cells(R, 91).Value = "" Then
Rprop.Value = False
Else
Rprop.Value = True
End If

If Sheet2.Cells(R, 92).Value = "" Then
Rcas.Value = False
Else
Rcas.Value = True
End If

If Sheet2.Cells(R, 93).Value = "" Then
Renv.Value = False
Else
Renv.Value = True
End If

If Sheet2.Cells(R, 94).Value = "" Then
Rauto.Value = False
Else
Rauto.Value = True
End If

If Sheet2.Cells(R, 95).Value = "" Then
Rspecial.Value = False
Else
Rspecial.Value = True
End If

If Sheet2.Cells(R, 96).Value = "" Then
Rother.Value = False
Else
Rother.Value = True
End If

If Sheet2.Cells(R, 102).Value = "Yes" Then
Ryes1.Value = True
Rno1.Value = False
Else
Ryes1.Value = False
Rno1.Value = True
End If


If R > 1 And R <= lastrow Then
UserForm1.Acname1.Value = Cells(R, 1).Value
UserForm1.LCfile.Value = Cells(R, 2).Value
UserForm1.Abbrv1.Value = Cells(R, 3).Value
UserForm1.Year1.Value = Cells(R, 4).Value
UserForm1.Pol1.Value = Cells(R, 5).Value
UserForm1.Sub1.Value = Cells(R, 6).Value
UserForm1.Loc1.Value = Cells(R, 7).Value
UserForm1.Dept1.Value = Cells(R, 8).Value
UserForm1.enter1.Value = Cells(R, 9).Value
UserForm1.Month1.Value = Cells(R, 10).Value
UserForm1.Order1.Value = Cells(R, 11).Value
UserForm1.Due1.Value = Cells(R, 12).Value
UserForm1.Extend1.Value = Cells(R, 13).Value
UserForm1.Extend2.Value = Cells(R, 14).Value
UserForm1.Date1.Value = Cells(R, 15).Value
UserForm1.Date2.Value = Cells(R, 16).Value
UserForm1.Req1.Value = Cells(R, 17).Value
UserForm1.Req2.Value = Cells(R, 18).Value
UserForm1.Req3.Value = Cells(R, 19).Value
Req3.Value = Format(Req3, "00")


UserForm1.State1.Value = Cells(R, 20).Value
UserForm1.Vendor1.Value = Cells(R, 21).Value
UserForm1.Status1.Value = Cells(R, 22).Value
UserForm1.Budget1.Value = Cells(R, 23).Value
UserForm1.Budget2.Value = Cells(R, 24).Value
Budget2.Value = Format(Budget2, "$#,##0.00")

UserForm1.OtherscopeN.Value = Cells(R, 35).Value
UserForm1.Notes1.Value = Cells(R, 36).Value

UserForm1.Recstatus.Value = Cells(R, 37).Value
UserForm1.RecCompDate.Value = Cells(R, 38).Value
UserForm1.RepRecs.Value = Cells(R, 39).Value
UserForm1.recletter.Value = Cells(R, 40).Value
UserForm1.Openrecs.Value = Cells(R, 41).Value
UserForm1.Complied1.Value = Cells(R, 42).Value
UserForm1.Ncrec1.Value = Cells(R, 43).Value
UserForm1.Ncrec2.Value = Cells(R, 44).Value
UserForm1.Ncrec3.Value = Cells(R, 45).Value
UserForm1.Absent1.Value = Cells(R, 46).Value
UserForm1.Totalrec1.Value = Cells(R, 47).Value
UserForm1.Perc1.Value = Cells(R, 48).Value
UserForm1.Perc2.Value = Cells(R, 49).Value
UserForm1.Perc3.Value = Cells(R, 50).Value
UserForm1.Perc4.Value = Cells(R, 51).Value

' UserForm1.QQip.Value = Cells(r, 52).Value
' UserForm1.QQc.Value = Cells(r, 53).Value
UserForm1.Days1.Value = Cells(R, 54).Value
UserForm1.Days3.Value = Cells(R, 55).Value
UserForm1.Days4.Value = Cells(R, 56).Value
UserForm1.Days2.Value = Cells(R, 57).Value

If Extend2.Value > 0 Then
Label54.Caption = "Yes"
Else
Label54.Caption = "No"
End If


UserForm1.RCorpAdd.Value = Cells(R, 58).Value
UserForm1.Rorder.Value = Cells(R, 59).Value
UserForm1.RDue.Value = Cells(R, 60).Value
UserForm1.Rreqn1.Value = Cells(R, 61).Value
UserForm1.Rreqn2.Value = Cells(R, 62).Value
UserForm1.Rrloc.Value = Cells(R, 63).Value
UserForm1.Rrphone.Value = Cells(R, 64).Value
Rrphone.Value = Format(Rrphone, "(###) ###-####")

UserForm1.Rregc.Value = Cells(R, 65).Value
Rregc.Value = Format(Rregc, "00")
UserForm1.Rrem.Value = Cells(R, 66).Value
UserForm1.Ruwn1.Value = Cells(R, 67).Value
UserForm1.Ruwn2.Value = Cells(R, 68).Value
UserForm1.RuwLoc.Value = Cells(R, 69).Value
UserForm1.Ruwp.Value = Cells(R, 70).Value
Ruwp.Value = Format(Ruwp, "(###) ###-####")
UserForm1.Ruwrc.Value = Cells(R, 71).Value
Ruwrc.Value = Format(Ruwrc, "00")
UserForm1.Ruwem.Value = Cells(R, 72).Value

UserForm1.Rwhole.Value = Cells(R, 73).Value
UserForm1.Rwname1.Value = Cells(R, 74).Value
UserForm1.Rwname2.Value = Cells(R, 75).Value
UserForm1.Rwadd1.Value = Cells(R, 76).Value
UserForm1.Rwadd2.Value = Cells(R, 77).Value
UserForm1.Rwadd3.Value = Cells(R, 78).Value
UserForm1.Rwadd4.Value = Cells(R, 79).Value
Rwadd4.Value = Format(Rwadd4, "00000")

UserForm1.Rwphone.Value = Cells(R, 80).Value
Rwphone.Value = Format(Rwphone, "(###) ###-####")

UserForm1.Rwem.Value = Cells(R, 81).Value
UserForm1.Rretail.Value = Cells(R, 82).Value
UserForm1.Rrwname1.Value = Cells(R, 83).Value
UserForm1.Rrwname2.Value = Cells(R, 84).Value
UserForm1.Rradd1.Value = Cells(R, 85).Value
UserForm1.Rradd2.Value = Cells(R, 86).Value
UserForm1.Rradd3.Value = Cells(R, 87).Value
UserForm1.Rradd4.Value = Cells(R, 88).Value
Rradd4.Value = Format(Rradd4, "00000")

UserForm1.Rrbphone.Value = Cells(R, 89).Value
Rrbphone.Value = Format(Rrbphone, "(###) ###-####")

UserForm1.Rrbem.Value = Cells(R, 90).Value

UserForm1.Rprops.Value = Cells(R, 91).Value
UserForm1.Rcass.Value = Cells(R, 92).Value
UserForm1.Renvs.Value = Cells(R, 93).Value
UserForm1.Rautos.Value = Cells(R, 94).Value
UserForm1.Rspecials.Value = Cells(R, 95).Value
UserForm1.Rothers.Value = Cells(R, 96).Value

UserForm1.Rnature.Value = Cells(R, 97).Value
UserForm1.RLoc.Value = Cells(R, 98).Value
UserForm1.Rcontact.Value = Cells(R, 99).Value
UserForm1.RContactp.Value = Cells(R, 100).Value
RContactp.Value = Format(RContactp, "(###) ###-####")

UserForm1.RspecialI.Value = Cells(R, 101).Value

UserForm1.RBLevel1.Value = Cells(R, 103).Value
UserForm1.RBLevel2.Value = Cells(R, 104).Value

UserForm1.LCfile.Value = RowNumber.Text - 1


ElseIf R = 1 Then
Cleardata

Else
Cleardata
MsgBox "Invalid Row Numer"
End If

With Application
.ScreenUpdating = True
.Calculation = xlCalculationManual
.EnableEvents = True
End With

snb
02-29-2016, 01:08 PM
You'd better upload your file.

You should reduce the writing/reading of cells to a minimum. Use arrays instead.

Loss1003
02-29-2016, 01:31 PM
Thanks. See attached.

I had to clear out 90% of the row data on sheet ("WS Form") in order to shrink the file size down.

snb
03-01-2016, 02:31 AM
That's definitely too much code for a simple task.

Your userform1_initialize event should look like:


Private Sub UserForm_Initialize()
TDate1 = Format(Date, "MM/DD/YYYY")
enter1 = "BA"
Status1 = "IP"
combranch.List = Sheet2.cells(1).currentregion.offset(2),resize(,2).Value

Acname1.List = Sheet2.Cells(1).CurrentRegion.Offset(1).Value
End Sub

Your acname1_change event should look like


Private Sub Acname1_Change()
If Acname1.ListIndex > -1 Then
For J = 0 To UBound(Acname1.List, 2)
Me("controlname") = Acname1.List(Acname1.ListIndex, jj)
Next
End If
End Sub

If you do that, a lot of your code isn't necessary any more.

Avoid the control_exit event: it's unpredictable.

Loss1003
03-01-2016, 06:51 AM
Thanks, will do.


What variable do i need to Dim J as?
&
should (Acname1.ListIndex, jj) be (Acname1.ListIndex, j)

snb
03-01-2016, 07:37 AM
Private Sub Acname1_Change()
If Acname1.ListIndex > -1 Then
For jj = 0 To UBound(Acname1.List, 2)
Me("controlname") = Acname1.List(Acname1.ListIndex, jj)
Next
End If
End Sub

NB. Remove/ comment out 'option explicit'

Paul_Hossler
03-01-2016, 07:51 AM
should (Acname1.ListIndex, jj) be (Acname1.ListIndex, j)

Or leave the Option Explicit, and



Dim jj as Long, j as Long


Instead of just grabbing the next letter, I've found that it's easier to maintain and debug (esp. months later) if I name the variables with a meaningful name

That way typos like 'j' instead of 'jj' are caught, esp. since I prefer to always use Option Explicit to ensure proper typing and declaration of variables

snb
03-01-2016, 08:34 AM
You can also use a more math based convention: j for rows, jj for columns:


sn=range("A1:K10")
for j=1 to ubound(sn)
for jj=1 to ubound(sn,2)
msgbox sn(j,jj)
next
next

If you do that, you will never have to invent names, nor to remember what you thougt 'meaningful' some years ago.
Since most of the posters here know only 1 language, they don't realize that communicating in different languages puts quite another light on 'meaningful'.
I don't think you'll understand the meaningfulness of "heteersteaaneengeslotengebied' or 'dieerstefünfspalten'.
So when communicatinge internationally it's preferable, like most mathematicians do, to use international math conventions.

Loss1003
03-01-2016, 12:56 PM
Thanks, will adjust the codes based on the above ones when appropriate.

Now I just need to optimize the following code to speed up the process of retrieving the information located on sheet2 and load them into the userform1 based on the rownumber displayed. When approx 4,000 or more rows are loaded in the WS, the userform1 operates very slowly due to trying to search an enter the info into the userform1.



Private Sub GetData()
Dim R As Long

lastrow = FindLastRow + 1

If IsNumeric(RowNumber.Text) Then
R = CLng(RowNumber.Text)

Else
Cleardata
MsgBox "Illegal Row Number"
Exit Sub

End If

If Sheet2.Cells(R, 25).Value = "X" Then
General.Value = True
End If
If Sheet2.Cells(R, 26).Value = "X" Then
Onsite.Value = True
End If
If Sheet2.Cells(R, 27).Value = "X" Then
Phone.Value = True
End If
If Sheet2.Cells(R, 28).Value = "X" Then
Desktop.Value = True
End If


If R > 1 And R <= lastrow Then
UserForm1.Acname1.Value = Cells(R, 1).Value
UserForm1.LCfile.Value = Cells(R, 2).Value
UserForm1.Abbrv1.Value = Cells(R, 3).Value
UserForm1.Year1.Value = Cells(R, 4).Value
UserForm1.Pol1.Value = Cells(R, 5).Value
UserForm1.Sub1.Value = Cells(R, 6).Value
UserForm1.Loc1.Value = Cells(R, 7).Value
UserForm1.Dept1.Value = Cells(R, 8).Value
UserForm1.enter1.Value = Cells(R, 9).Value
UserForm1.Month1.Value = Cells(R, 10).Value
UserForm1.Order1.Value = Cells(R, 11).Value
UserForm1.Due1.Value = Cells(R, 12).Value
UserForm1.Extend1.Value = Cells(R, 13).Value
UserForm1.Extend2.Value = Cells(R, 14).Value
UserForm1.Date1.Value = Cells(R, 15).Value
UserForm1.Date2.Value = Cells(R, 16).Value
UserForm1.Req1.Value = Cells(R, 17).Value
UserForm1.Req2.Value = Cells(R, 18).Value
UserForm1.Req3.Value = Cells(R, 19).Value
UserForm1.LCfile.Value = RowNumber.Text - 1
'DisableSave

ElseIf R = 1 Then
Cleardata

Else
Cleardata
MsgBox "Invalid Row Numer"
End If

Paul_Hossler
03-01-2016, 05:25 PM
The xlsm in the zip was 4 MB

1. If I clear most of the 14,000 styles that aren't being used



Option Explicit
Sub DeleteStyles()
Dim i As Long

For i = ThisWorkbook.Styles.Count To 1 Step -1
With ThisWorkbook.Styles(i)
If Not .BuiltIn Then
On Error Resume Next
Debug.Print i & " -- " & .Name
.Delete
On Error GoTo 0
DoEvents
End If
End With
Next i
End Sub



2. Remove the borders on WS_FORM (since it seems that the user won't see the data on the WS, only via the user form)

3. Clear rows 128 to the end and columns DA to the end

the WB ends up around 1.5 MB

4. There are a few suggestions (mostly personal coding style) that could help a very minor bit




'If rn.Offset(0, 24) = "X" Then
'General.Value = True
'End If


With rn
General.Value = (.Offset(0, 24) = "X")



End With




5. GetData is called by RowNumber_Change and seems pretty quick. There are no loops or gross slowdowns that I could see in that Sub. If you put a breakpoint on that line, and execute it (SHift-F9) it seem pretty fast

6. Maybe you should use a fully loaded WB and put some break points and step through it to see where the slowdown is occurring.

snb
03-02-2016, 02:33 AM
You can load the whole database in a combobox/listbox.
So you won't need 'findlastrow', nor' cleardata', nor 'getdata'

cfr. http://www.snb-vba.eu/VBA_Userform_in_database_en.html

Loss1003
03-02-2016, 08:00 PM
Thanks for the further suggestions. I've been teasing with it all day and have made some progress.
I think the reason behind the data slowing loading whenever the Getdata code was run or when the previous, next, last command buttons was due to a few lines such as located at the top of the code under option explicit: Dim lastrow As Long.

I further tinkered and removed the previous rownumber textbox and replaced it with the LCFile textbox. Hence, I need to adjust the coding in the last command button. Because after the last command button is clicked the last row will appear correctly. However, when I click the previous or next commandbutton I get an error MsgBox "Account Name not found. Please Try Again.", when in-fact I should be retrieving the previous row data.

Please assist or offer suggestions on how to revise the code to work properly.

Further notes, I’ve also edited the Getdata code to mimic the search (cmdbranch) code.

Please see the attached revised excel sheet, I removed all the unnecessary coding to help navigate thru the codes better.

Once again thanks for helping me thru this project

Loss1003
03-03-2016, 09:05 AM
I see the problem lies in the lcfile textbox whenever the number reaches 1000 or 1001 and greater the msgbox pops up in lieu of the previous or next row.

Loss1003
03-03-2016, 02:41 PM
I've fixed the other issues and now i have an issue with saving the data from the userform to the worksheet. It saves to the row above the row that it should save the data to. Please help amend the code to save on the proper row.



Dim r As Long

If IsNumeric(LCfile.Text) Then
'r = CLng(RowNumber.Text)
r = CLng(LCfile.Text)
Else
MsgBox "Illegal row number"
Exit Sub

End If

If r >= 1 And r <= LCfile Then
Cells(r, 1) = Acname1.Text
Cells(r, 2) = LCfile.Text
Cells(r, 3) = Abbrv1.Text
Cells(r, 4) = Year1.Text
Cells(r, 5) = Pol1.Text
Cells(r, 6) = Sub1.Text
Cells(r, 7) = Loc1.Text
Cells(r, 8) = Dept1.Text
Cells(r, 9) = enter1.Text
Cells(r, 10) = Month1.Text
Cells(r, 11) = Order1.Text
Cells(r, 12) = Due1.Text
Cells(r, 13) = Extend1.Text
Cells(r, 14) = Extend2.Text
Cells(r, 15) = Date1.Text
Cells(r, 16) = Date2.Text
Cells(r, 17) = Req1.Text
Cells(r, 18) = Req2.Text
Cells(r, 19) = Req3.Text
Cells(r, 20) = State1.Text
Cells(r, 21) = Vendor1.Text
Cells(r, 22) = Status1.Text
Cells(r, 23) = Budget1.Text
Cells(r, 24) = Budget2.Text


Cells(r, 35) = OtherscopeN.Text
Cells(r, 36) = Notes1.Text

Cells(r, 37) = Recstatus.Text
Cells(r, 38) = RecCompDate.Text
Cells(r, 39) = RepRecs.Text
Cells(r, 40) = recletter.Text
Cells(r, 41) = Openrecs.Text
Cells(r, 42) = Complied1.Text
Cells(r, 43) = Ncrec1.Text
Cells(r, 44) = Ncrec2.Text
Cells(r, 45) = Ncrec3.Text
Cells(r, 46) = Absent1.Text
Cells(r, 47) = Totalrec1.Text
Cells(r, 48) = Perc1.Text
Cells(r, 49) = Perc2.Text
Cells(r, 50) = Perc3.Text
Cells(r, 51) = Perc4.Text

Cells(r, 54) = Days1.Text
Cells(r, 55) = Days3.Text
Cells(r, 56) = Days2.Text
Cells(r, 57) = Days2.Text






End If

SamT
03-03-2016, 03:47 PM
another coding style that will save some time

UserForm1.Acname1.Value = Cells(R, 1).Value
UserForm1.LCfile.Value = Cells(R, 2).Value
UserForm1.Abbrv1.Value = Cells(R, 3).Value
UserForm1.Year1.Value = Cells(R, 4).Value
UserForm1.Pol1.Value = Cells(R, 5).Value
UserForm1.Sub1.Value = Cells(R, 6).Value
UserForm1.Loc1.Value = Cells(R, 7).Value
UserForm1.Dept1.Value = Cells(R, 8).Value
UserForm1.enter1.Value = Cells(R, 9).Value
UserForm1.Month1.Value = Cells(R, 10).Value
UserForm1.Order1.Value = Cells(R, 11).Value
UserForm1.Due1.Value = Cells(R, 12).Value
UserForm1.Extend1.Value = Cells(R, 13).Value
UserForm1.Extend2.Value = Cells(R, 14).Value
UserForm1.Date1.Value = Cells(R, 15).Value
UserForm1.Date2.Value = Cells(R, 16).Value
UserForm1.Req1.Value = Cells(R, 17).Value
UserForm1.Req2.Value = Cells(R, 18).Value
UserForm1.Req3.Value = Cells(R, 19).Value
UserForm1.LCfile.Value = RowNumber.Text - 1


MyValues = Range(Cells(R, 1), Cells(R, 19))
With UserForm1
.Acname1 = MyValues(0)
.LCfile = MyValues(1)
.Abbrv1 = MyValues(2)
.Year1 = MyValues(3)
.Pol1 = MyValues(4)
.Sub1 = MyValues(5)
.Loc1 = MyValues(6)
.Dept1 = MyValues(7)
.enter1 = MyValues(8)
.Month1 = MyValues(9)
.Order1 = MyValues(10)
.Due1 = MyValues(11)
.Extend1 = MyValues(12)
.Extend2 = MyValues(13)
.Date1 = MyValues(14)
.Date2 = MyValues(15)
.Req1 = MyValues(16)
.Req2 = MyValues(17)
.Req3 = MyValues(18)
.LCfile = RowNumber.Text - 1
End With

and isn't R = RowNumber.Text

Paul_Hossler
03-03-2016, 04:56 PM
It saves to the row above the row that it should save the data to. Please help amend the code to save on the proper row.



As a guess ...



r = CLng(LCfile.Text) + 1