# Speed up code

#### Kavy

##### Well-known Member
Hello All, big favor to ask if anyone is willing to do it.
If I e-mail me code to anyone for one of my subs (in excel vb userform)
anyone willing to take a look at it and see if they can speed it up, if anyone has time on there hands?

If anyone responds , heh, thanks!

When I say speed up, i mean more effiant for the computer to run so it goes quicker, thanks!

### Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Why not post the code?

Ok here goes, very long.

Some quick things, worksheet("List") is just a list of the equipment which has been already included by the code. If it is doing it for a second time, changing its delivery date it writes "Deleted" in one of the columns on the worksheet list, and writes a new row.

It writes by a worksheet noted by w. aka worksheet(w)

it reads off a worksheet selected by the user on the listworksheet. It is organized by row by tag number. Each tag number has a list of work and a list of frequancys to go with that work, these are sorted by alt- enters, or chr(10). Some don't have frequancys these are my special cases.

There is sheets Called "Day sheets" they are for referance by another sub

There is a form called frmequip that loads, that just makes the user move what equipment they want to include from one list to another and just includes the equipment from the second list

Command button "OK" runs it

Code:
``````Sub room(colc, rowc, w)

If colc >= 221 And rowc >= 64001 Then
w = w + 1
Set wsc = Worksheets(w)
colc = 1
rowc = 2
End If

If rowc >= 64001 Then
colc = colc + 20
rowc = 2
End If

End Sub

Public Sub cmdOK_Click()

Dim data(1, 1, 1, 1, 1, 1, 1, 1, 1) As String
'(Equipment Tag, Delivery date, maint freq, required maintaince, Maintance Date, notes, completed?,description,maint instruc)
Dim a As Integer ' Array variables
Dim b As Integer
Dim c As Integer
Dim d As Integer
Dim e As Integer
Dim f As Integer
Dim g As Integer
Dim h As Integer
Dim j As Integer
Dim extra As Date ' holds values for array while switching parts (used for calculating days from freq)
Dim dd As Date 'Delivery date
Dim rowSS(1000) As Integer
Dim tag As String
Dim w As Integer
Dim Show_Box As Boolean
Dim DDate As Variant
Dim row As Integer
Dim col As Integer
Dim flag As Integer
Dim ws As Worksheet ' reading from this sheet
'writing from this sheet
Dim wsl As Worksheet
Dim rowc As Double 'row being writting to
Dim gcol As Integer 'col grabing data
Dim Tcol As Integer 'col tag numbers are reading from
Dim fcol As Integer
Dim dcol As Integer
Dim rcol As Integer
Dim mcol As Integer
Dim ncol As Integer
Dim ccol As Integer
Dim Notes As String
Dim check As Integer
Dim listt(200000) As String
Dim p As Integer
Dim rowl As Integer
Dim index As Integer ' which alt- enter (counting down from top)
Dim place As Integer  'Placement of the line break (alt - enter)
Dim plholder As Integer ' takes the place value at end of loop
Dim cell As String 'Data in cell (changes every loop)
Dim distance As Integer 'distance from one alt-enter to another
Dim length As Integer 'length of all contents in cell (length of cell string)
Dim LPflag(30) As String 'For the exceptions where the cells don't match up
Dim i As Double 'clears the array
Dim colc As Integer
Dim TTags As Integer 'Total amount of Tags on list
Dim resp As Integer
Dim today As Date
Dim rowp As Integer
Dim rowd As Double
Dim cold As Double
Dim daycheck As Integer
Dim wsc As Worksheet 'Data base sheets. Fills to 65000 collums then moves over by 20 collums
Dim yearl As Long
Dim year(1) As Double
Dim monthl As Long
Dim weekl As Long
Dim dayl As Long
Dim month(1) As Double
Dim week(1) As Double
Dim day(1) As Double
Dim OT As Long

If listWorksheet.listIndex = -1 Then
Exit Sub
End If

Set ws = Worksheets(listWorksheet.list(listWorksheet.listIndex))
Set wsl = Worksheets("List")
Dim intervall As String
today = Date

p = 0
Tcol = 3
fcol = 10
dcol = 12
rcol = 9
mcol = 13  'CHANGE
ncol = 14
ccol = 15
ddcol = 2
check = 0
flag = 1
col = 12
DDate = 1
tag = "1"
rowc = 1
gcol = 1
resp = 1
rowl = 1
frmEquip.listEquip.Clear
frmEquip.listEquip2.Clear

Do

If wsl.cells(rowl, 1) = "" Then
TTags = rowl
Exit Do
Else
rowl = rowl + 1
End If

Loop While rowl < 8000 'Changable

rowl = 1

'*********Getting Date Input from User**************************************
DDate = txtDate.Value

If DDate = "" Then
MsgBox ("You did not enter any date, please try again")
Exit Sub
Else    ' Test Entry to find out if it is numeric.

If IsDate(DDate) = True Then

ElseIf StrComp(DDate, "None", 3) = 0 Then
Else
Exit Sub
End If
End If

'****************************Getting Tag number from user*********************************
tag = txtTagNum.Value

If tag = "" Then
MsgBox ("You did not enter any tag number")
Exit Sub
End If

row = 2
If tag = "all" Then
Do
listt(p) = ws.cells(row, 3)
row = row + 1
Loop While ws.cells(row, 3) <> ""
flag = 0

Else

Do
If StrComp(tag, ws.cells(row, 3), 1) = 0 Then
listt(p) = ws.cells(row, 3)
flag = 0
rowl = 1
a = 1
Do

If StrComp(ws.cells(row, 3), wsl.cells(rowl, 1)) = 0 Then
a = 0
Exit Do
End If

rowl = rowl + 1
Loop While rowl <= TTags

If a = 1 Then
End If

p = p + 1

ElseIf InStr(1, ws.cells(row, 3), tag, 1) > 0 Then
listt(p) = ws.cells(row, 3)
flag = 0
rowl = 1
a = 1

Do

If StrComp(ws.cells(row, 3), wsl.cells(rowl, 1)) = 0 Then
a = 0
'frmEquip.listEquip.Font.Bold = False
Exit Do
End If

rowl = rowl + 1
Loop While rowl <= TTags

If a = 1 Then
End If

p = p + 1
End If

row = row + 1

Loop While row < 1500 ' may want user to change

End If

If flag = 1 Then
tag = MsgBox("Could not find the equipment searched for.")
Exit Sub
End If

frmEquip.Show
If frmEquip.lblclose.Caption = "close" Then
frmEquip.lblclose.Caption = ""
Exit Sub
End If

p = 0
Do
listt(i) = 0
i = i + 1
Loop While i < 200001

'*****Getting data from second list*******
Do
listt(p) = frmEquip.listEquip2.list(p)
p = p + 1
Loop While p < frmEquip.listEquip2.ListCount

p = 0

Do
flag = 0
row = 1

Do   '**** Finding Tag on orginal list ***********

If StrComp(listt(p), ws.cells(row, 3), 1) = 0 Then
Exit Do
Else
row = row + 1
End If

Loop While row < 11000
'**************** Checking if its been done before****   Make a note come up if it has

If rowp > TTags Then
Exit Do
End If
rowl = 1
Do
If StrComp(listt(p), wsl.cells(rowl, 1), vbTextCompare) = 0 And wsl.cells(rowl, 5) <> "Deleted" Then
rowc = wsl.cells(rowl, 3)
colc = wsl.cells(rowl, 4)
w = wsl.cells(rowl, 2)
Set wsc = Worksheets(w)
flag = 4 'Means its already on list
Exit Do
ElseIf StrComp(listt(p), wsl.cells(rowl, 1), vbTextCompare) = 0 Then
If wsl.cells(rowl, 9) = "yes" And DDate = "Now" Then
MsgBox ("The PM has Already been stoped for this Equipment by the STOP/START PM Button on the Main Menu")
Exit Sub
End If
End If
rowl = rowl + 1
Loop While rowl <= 12000

rowc = wsl.cells(TTags - 1, 3)
colc = wsl.cells(TTags - 1, 4)
w = wsl.cells(TTags - 1, 2)
Set wsc = Worksheets(w)
If DDate = "None" Then
MsgBox ("You cannot enter None for the date of Equipment that has not started PM yes")
Exit Sub
End If
resp = MsgBox("IMPORTANT - Some or all the Tag numbers you selected or entered have had PM Start already for them, if you change the PM Start Date, all non-completed work will be DELETED!. ARE YOU SURE YOU WANT TO CONTINUE?", 4, "WARNING")
If resp = 7 Then
Exit Sub
End If
Do
Exit Do
Else
resp = MsgBox("Wrong password, do you want to try again?", 4)
If resp = 7 Then
Exit Sub
End If
End If
Loop
End If
'*******Checking if theres room left on worksheet****
Do
If wsc.cells(rowc, 7) <> "yes" Then
gcol = 2
Do
wsc.cells(rowc, gcol - 1 + colc) = "Deleted"
gcol = gcol + 1
Loop While gcol <= 20
End If
rowc = rowc + 1
Call room(colc, rowc, w)
Loop While StrComp(listt(p), wsc.cells(rowc, 1)) = 0

rowc = wsl.cells(TTags - 1, 3)
colc = wsl.cells(TTags - 1, 4)
w = wsl.cells(TTags - 1, 4)
Set wsc = Worksheets(w)
wsl.cells(rowl, 5) = "Deleted"
wsl.cells(rowl, 8) = Date

If DDate = "None" Then
Exit Sub
End If

End If

Do
If wsc.cells(rowc, colc) = "" Then
Exit Do
End If
rowc = rowc + 1
Call room(colc, rowc, w)
Loop
rowl = TTags

a = 0
b = 0
c = 0
d = 0
e = 0
f = 0
g = 0
h = 0
j = 0
Notes = txtNotes.Value
'*********************Getting data from orginial worksheet***********
'*** TaG***
a = 1
data(a, b, c, d, e, f, g, h, j) = ws.cells(row, Tcol)
a = 1
'***** Delivery Date*******
b = 1
data(a, b, c, d, e, f, g, h, j) = DDate
'maintaince freq
c = 1
'maintaince required
d = 1
'maintaince dates
e = 1
'Notes
f = 1
data(a, b, c, d, e, f, g, h, j) = Notes
'Completed??
g = 1
h = 1
data(a, b, c, d, e, f, g, h, j) = ws.cells(row, 4)
j = 1
data(a, b, c, d, e, f, g, h, j) = ws.cells(row, 11)
'******* Getting Maintaince freq/required **********
plholder = 0
plholderh = 0
flag = 9

Do  'Sorting through Alt-Enters **********************************
LPlace = 0
cell = ws.cells(row, fcol)
index = 1

If cell <> "" Then

Do

If wsc.cells(rowc, colc) = "" Then
Exit Do
End If

rowc = rowc + 1
Loop While rowc <= 64000

Call room(colc, rowc, w)

If flag = 9 Then
wsl.cells(rowl, 1) = data(1, 0, 0, 0, 0, 0, 0, 0, 0)
wsl.cells(rowl, 2) = w
wsl.cells(rowl, 3) = rowc
wsl.cells(rowl, 4) = colc
wsl.cells(rowl, 6) = data(1, 1, 0, 0, 0, 0, 0, 0, 0)
wsl.cells(rowl, 7) = today
flag = 10
TTags = TTags + 1
End If

b = 0
c = 0
d = 0
e = 0
f = 0
g = 0
h = 0
j = 0
gcol = colc
wsc.cells(rowc, gcol) = data(a, b, c, d, e, f, g, h, j)

b = 1
gcol = 1 + colc
wsc.cells(rowc, gcol) = data(a, b, c, d, e, f, g, h, j)

c = 1
d = 1
gcol = 3 + colc

e = 1
f = 1
gcol = 5 + colc
wsc.cells(rowc, gcol) = data(a, b, c, d, e, f, g, h, j)
g = 1
h = 1
gcol = 7 + colc
wsc.cells(rowc, gcol) = data(a, b, c, d, e, f, g, h, j)
j = 1
gcol = 10 + colc
wsc.cells(rowc, gcol) = data(a, b, c, d, e, f, g, h, j)

a = 1
b = 1
c = 1
d = 0
e = 0
f = 0
g = 0
h = 0
j = 0
gcol = 3
i = 1

Do   '*** Getting Freq****
LPflag(i) = 0
i = i + 1
Loop While i < 31

length = Len(cell)
place = InStr(plholder + 1, cell, Chr(10), 1)
distance = place - plholder

If distance <= 0 Then
data(a, b, c, d, e, f, g, h, j) = Mid(cell, plholder + 1, length)
data(a, b, c, d, e, f, g, h, j) = Trim(data(a, b, c, d, e, f, g, h, j))

Else
data(a, b, c, d, e, f, g, h, j) = Mid(cell, plholder + 1, distance - 1)
data(a, b, c, d, e, f, g, h, j) = Trim(data(a, b, c, d, e, f, g, h, j))

End If

check = place

'*** Getting Maitaince req****

c = 1
d = 1
gcol = 4
cell = ws.cells(row, rcol)
length = Len(cell)
place = InStr(plholderh + 1, cell, Chr(10), 1)
distance = place - plholderh

If distance <= 0 Then
data(a, b, c, d, e, f, g, h, j) = Mid(cell, plholderh + 1, length)
data(a, b, c, d, e, f, g, h, j) = Trim(data(a, b, c, d, e, f, g, h, j))
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)
Else
data(a, b, c, d, e, f, g, h, j) = Mid(cell, plholderh + 1, distance - 1)
data(a, b, c, d, e, f, g, h, j) = Trim(data(a, b, c, d, e, f, g, h, j))
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)
End If

'** Checking special cases**

If data(a, b, c, d, e, f, g, h, j) = "IH" Then
LPflag(index) = 1
ElseIf data(a, b, c, d, e, f, g, h, j) = "I" Then
LPflag(index) = 1
ElseIf data(a, b, c, d, e, f, g, h, j) = "O" Then
LPflag(index) = 1
ElseIf data(a, b, c, d, e, f, g, h, j) = "OC" Then
LPflag(index) = 1
ElseIf data(a, b, c, d, e, f, g, h, j) = "SITE" Then
LPflag(index) = 1
ElseIf data(a, b, c, d, e, f, g, h, j) = "M" Then
LPflag(index) = 1
End If

If LPflag(index) = 1 Then
d = 0
gcol = 3
data(a, b, c, d, e, f, g, h, j) = "No data"
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)
End If

d = 0
'Calculating Maintance days***

If data(a, b, c, d, e, f, g, h, j) = "Init'l" Then
wsc.cells(rowc, 2 + colc) = "Intial"
c = 0
extra = data(a, b, c, d, e, f, g, h, j)
c = 1
d = 1
e = 1
data(a, b, c, d, e, f, g, h, j) = extra
gcol = 5
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)
Call DayList(rowc, colc, w, daycheck, extra)

'2 weeks*********************************

ElseIf data(a, b, c, d, e, f, g, h, j) = "Init l &@2WK" Or data(a, b, c, d, e, f, g, h, j) = "Intial" Then
c = 0
extra = data(a, b, c, d, e, f, g, h, j)
c = 1
d = 1
e = 1
data(a, b, c, d, e, f, g, h, j) = extra
wsc.cells(rowc, 2 + colc) = "Intial"
Call DayList(rowc, colc, w, daycheck, extra)
gcol = 5
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)
rowc = rowc + 1
Call room(colc, rowc, w)
wsc.cells(rowc, gcol - 1 + colc) = extra

b = 0
c = 0
d = 0
e = 0
f = 0
g = 0
h = 0
j = 0
gcol = 1
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)

b = 1
gcol = 2
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)

c = 1
gcol = 3
wsc.cells(rowc, gcol - 1 + colc) = "One Time @ 0 years 0 months 2 weeks 0 days"

d = 1
gcol = 4
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)

e = 1
f = 1
gcol = 6
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)
g = 1
h = 1
gcol = 8
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)
j = 1
gcol = 11
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)
Call DayList(rowc, colc, w, daycheck, extra)
f = 0
g = 0
h = 0
j = 0

ElseIf InStr(1, data(a, b, c, d, e, f, g, h, j), "One time @ ", vbTextCompare) > 0 Then
OTl = InStr(1, data(a, b, c, d, e, f, g, h, j), "One Time @ ", vbTextCompare)
yearl = InStr(1, data(a, b, c, d, e, f, g, h, j), " years", vbTextCompare)
year(1) = Trim(Mid(data(a, b, c, d, e, f, g, h, j), 11, yearl - 11))
monthl = InStr(1, data(a, b, c, d, e, f, g, h, j), " months", vbTextCompare)
month(1) = Trim(Mid(data(a, b, c, d, e, f, g, h, j), yearl + 6, monthl - yearl - 6))
weekl = InStr(1, data(a, b, c, d, e, f, g, h, j), " weeks", vbTextCompare)
week(1) = Trim(Mid(data(a, b, c, d, e, f, g, h, j), monthl + 7, weekl - monthl - 7))
dayl = InStr(1, data(a, b, c, d, e, f, g, h, j), " days", vbTextCompare)
day(1) = Trim(Mid(data(a, b, c, d, e, f, g, h, j), weekl + 7, dayl - weekl - 7))
extra = Date
wsc.cells(rowc, colc) = data(1, 0, 0, 0, 0, 0, 0, 0, 0)
wsc.cells(rowc, colc + 1) = data(1, 1, 0, 0, 0, 0, 0, 0, 0)
wsc.cells(rowc, colc + 2) = data(1, 1, 1, 0, 0, 0, 0, 0, 0)
wsc.cells(rowc, colc + 3) = data(1, 1, 1, 1, 0, 0, 0, 0, 0)
wsc.cells(rowc, colc + 4) = extra
wsc.cells(rowc, colc + 5) = data(1, 1, 1, 1, 1, 1, 0, 0, 0)
wsc.cells(rowc, colc + 7) = data(1, 1, 1, 1, 1, 1, 1, 1, 0)
wsc.cells(rowc, colc + 10) = data(1, 1, 1, 1, 1, 1, 1, 1, 1)
Call DayList(rowc, colc, w, daycheck, extra)

ElseIf InStr(1, data(a, b, c, d, e, f, g, h, j), " years", vbTextCompare) > 0 Then
yearl = InStr(1, data(a, b, c, d, e, f, g, h, j), " years", vbTextCompare)
year(1) = Trim(Mid(data(a, b, c, d, e, f, g, h, j), 1, yearl))
monthl = InStr(1, data(a, b, c, d, e, f, g, h, j), " months", vbTextCompare)
month(1) = Trim(Mid(data(a, b, c, d, e, f, g, h, j), yearl + 6, monthl - yearl - 6))
weekl = InStr(1, data(a, b, c, d, e, f, g, h, j), " weeks", vbTextCompare)
week(1) = Trim(Mid(data(a, b, c, d, e, f, g, h, j), monthl + 7, weekl - monthl - 7))
dayl = InStr(1, data(a, b, c, d, e, f, g, h, j), " days", vbTextCompare)
day(1) = Trim(Mid(data(a, b, c, d, e, f, g, h, j), weekl + 7, dayl - weekl - 7))
extra = Date
Do

If extra <= "Jan 1 2014" Then
wsc.cells(rowc, colc) = data(1, 0, 0, 0, 0, 0, 0, 0, 0)
wsc.cells(rowc, colc + 1) = data(1, 1, 0, 0, 0, 0, 0, 0, 0)
wsc.cells(rowc, colc + 2) = data(1, 1, 1, 0, 0, 0, 0, 0, 0)
wsc.cells(rowc, colc + 3) = data(1, 1, 1, 1, 0, 0, 0, 0, 0)
wsc.cells(rowc, colc + 4) = extra
wsc.cells(rowc, colc + 5) = data(1, 1, 1, 1, 1, 1, 0, 0, 0)
wsc.cells(rowc, colc + 7) = data(1, 1, 1, 1, 1, 1, 1, 1, 0)
wsc.cells(rowc, colc + 10) = data(1, 1, 1, 1, 1, 1, 1, 1, 1)
Call DayList(rowc, colc, w, daycheck, extra)
rowc = rowc + 1
Call room(colc, rowc, w)
End If

Loop While extra <= "Jan 1 2014"

Else
Dim interval As String
Dim amount As Integer

If data(a, b, c, d, e, f, g, h, j) = "2 Wk" Or data(a, b, c, d, e, f, g, h, j) = "2Weeks" Or data(a, b, c, d, e, f, g, h, j) = "2 Weeks" Or data(a, b, c, d, e, f, g, h, j) = "2 Wks" Or data(a, b, c, d, e, f, g, h, j) = "2wks" Then
wsc.cells(rowc, colc + 2) = "0 years 0 months 2 weeks 0 days"
intervall = "0 years 0 months 2 weeks 0 days"
interval = "ww"
amount = 1
ElseIf StrComp(data(a, b, c, d, e, f, g, h, j), "1 Mon", vbTextCompare) = 0 Or data(a, b, c, d, e, f, g, h, j) = "1 Mon." Then
wsc.cells(rowc, colc + 2) = "0 years 1 months 0 weeks 0 days"
intervall = "0 years 1 months 0 weeks 0 days"
interval = "m"
amount = 1
ElseIf data(a, b, c, d, e, f, g, h, j) = "2 Mon" Or data(a, b, c, d, e, f, g, h, j) = "2 Mons" Then
wsc.cells(rowc, colc + 2) = "0 years 3 months 0 weeks 0 days"
intervall = "0 years 3 months 0 weeks 0 days"
interval = "m"
amount = 1
ElseIf data(a, b, c, d, e, f, g, h, j) = "3 Mon" Or data(a, b, c, d, e, f, g, h, j) = "3 Mons" Then
wsc.cells(rowc, colc + 2) = "0 years 3 months 0 weeks 0 days"
interval = "m"
intervall = "0 years 3 months 0 weeks 0 days"
amount = 3
ElseIf data(a, b, c, d, e, f, g, h, j) = "No data" Then

Else

'MsgBox ("Missing date   " & data(a, b, c, d, e, f, g, h, j))
End If

d = 0
c = 0
extra = data(a, b, c, d, e, f, g, h, j)
dd = extra
c = 1
d = 1
e = 1

Do
f = 0
g = 0
h = 0
j = 0
data(a, b, c, d, e, f, g, h, j) = extra
gcol = 5
Call room(colc, rowc, w)
Call DayList(rowc, colc, w, daycheck, extra)
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)

b = 0
c = 0
d = 0
e = 0
f = 0
g = 0
h = 0
j = 0
gcol = 1
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)

b = 1
gcol = 2
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)

c = 1
gcol = 3
wsc.cells(rowc, gcol - 1 + colc) = intervall

d = 1
gcol = 4
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)

e = 1
f = 1
gcol = 6
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)

g = 1
h = 1
gcol = 8
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)
gcol = 11
j = 1
wsc.cells(rowc, gcol - 1 + colc) = data(a, b, c, d, e, f, g, h, j)
rowc = rowc + 1

Loop While extra < "Jan 1 2014" 'Something you might want user to change
End If

plholderh = place

If LPflag(index) <> 1 Then
plholder = check
End If

index = index + 1
End If
If cell = "" Then
Exit Do
End If

Loop While distance > 0

p = p + 1

Loop While p < frmEquip.listEquip2.ListCount
frmEquip.listEquip.Clear
frmEquip.listEquip2.Clear
frmDates.Hide
Worksheets("More then Seven").cells(9, 9) = Now
End Sub
Sub DayList(rowc, colc, w, daycheck, extra)
Dim rowd As Double
Dim cold As Double
Dim lastRow1 As Date
Dim lastRow2 As Date
Dim lastRow3 As Date
Dim flagg As Integer

Dim dws As Worksheet
Dim dws1 As Worksheet
Dim dws2 As Worksheet
Dim dws3 As Worksheet
Set dws1 = Worksheets("Day sheet 1")
Set dws2 = Worksheets("Day sheet 2")
Set dws3 = Worksheets("Day sheet 3")

lastRow1 = dws1.cells(63902, 1)
lastRow2 = dws2.cells(63902, 1)
lastRow3 = dws3.cells(63902, 1)

rowd = 2
cold = 2
flagg = 0
If extra > lastRow1 Then
If extra > lastRow2 Then
Set dws = dws3
Else
Set dws = dws2
End If
Else
Set dws = dws1
End If

If extra > lastRow3 Then
MsgBox ("Problem contact Shaun")
End If

Do
If dws.cells(rowd, 1) = extra Then
Do
If dws.cells(rowd, cold) = "" Then
dws.cells(rowd, cold) = w
cold = cold + 1
dws.cells(rowd, cold) = rowc
cold = cold + 1
dws.cells(rowd, cold) = colc
flagg = 1
Exit Do
Else
cold = cold + 1

If cold = 253 Then
rowd = rowd + 1
cold = 2
End If
End If
If rowd = 64000 Then
MsgBox ("Error")
End If
Loop
End If
rowd = rowd + 50
Loop While flagg = 0

End Sub

'Private Sub UserForm_Click()
Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
Cancel = True
End If

End Sub``````

Right I'm just having me tea but I can immediately see some problems with the code, though they may not be connected to the speed.

Do not use variable names like week, day, month, today, index etc, they are VBA functions/properties.

It also appears that you have a lot of, at first glance anyway, unneeded looping going on.

I'll take a closer look once I've finished my chips.

Too long codes,split it to several subroutines.

Without attachment,It's hardly to understand your meaning.

Regards

Northwolves

thanks! but splitting into subs, won't speed it up, just make it easier to understand, edit, and read, correct?

just as a repost for today, anyone else?
Thanks for any suggestions!

This is what I use initially.
Code:
``````Sub SpeedUp()
On Error GoTo EndNow
Applicaiton.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'code here

EndNow:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub``````

TTags, is the last row on a sheet that has data in it. rowl is the row variable for that sheet.

Don't I need a loop to do this? Sorry I don't get how you went about doing it

Replies
7
Views
171
Replies
4
Views
204
Replies
2
Views
221
Replies
4
Views
375
Replies
12
Views
716

1,219,581
Messages
6,149,119
Members
450,861
Latest member
metcala

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back