Speed up code

Kavy

Well-known Member
Joined
Jun 25, 2007
Messages
607
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

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,357
Office Version
  1. 365
Platform
  1. Windows
Why not post the code?
 

Kavy

Well-known Member
Joined
Jun 25, 2007
Messages
607
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

Any other quesitons please ask and thanks to anyone that attemps!

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
    MsgBox ("Please Select the Worksheets")
    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
 Password = "Default"
 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
        MsgBox ("Error - Could not read the Date, please try again")
        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

 '*****************Adding Tag number to list*************

row = 2
If tag = "all" Then
        Do
            listt(p) = ws.cells(row, 3)
            frmEquip.listEquip2.AddItem (listt(p))
            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
                        frmEquip.listEquip.AddItem (listt(p)) ' & " Already Delivered")
                        a = 0
                        Exit Do
                    End If
        
                    rowl = rowl + 1
                Loop While rowl <= TTags
        
                If a = 1 Then
                    frmEquip.listEquip.AddItem (listt(p))
                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
                        frmEquip.listEquip.AddItem (listt(p)) ' & "      ALREADY DELIVERED!!")
                        a = 0
                        'frmEquip.listEquip.Font.Bold = False
                        Exit Do
                    End If
            
                    rowl = rowl + 1
                Loop While rowl <= TTags
        
                If a = 1 Then
                    frmEquip.listEquip.AddItem (listt(p))
                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
Password = "Wrong"
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
        
        If flag = 0 Then 'was not found on already added list
            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
        Else ' was found on the already added list
            If Password <> "Shaun" Then
                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
                        Password = InputBox("Please Enter the Password")
                        If Password = "Shaun" Then
                            MsgBox ("Correct Password")
                            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)
                extra = DateAdd("ww", 2, extra)
                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
                            extra = DateAdd("yyyy", year(1), extra)
                            extra = DateAdd("m", month(1), extra)
                            extra = DateAdd("ww", week(1), extra)
                            extra = DateAdd("d", day(1), extra)
                            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

                           
                            extra = DateAdd("yyyy", year(1), extra)
                            extra = DateAdd("m", month(1), extra)
                            extra = DateAdd("ww", week(1), extra)
                            extra = DateAdd("d", day(1), extra)
                            
                            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
                    extra = DateAdd(interval, amount, extra)
                    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)
  If CloseMode = vbFormControlMenu Then
    Cancel = True
    MsgBox "Please use a button!"
  End If

End Sub
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,357
Office Version
  1. 365
Platform
  1. Windows
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.:)
 

Kavy

Well-known Member
Joined
Jun 25, 2007
Messages
607
take your time and thanks!
 

northwolves

Well-known Member
Joined
Jun 21, 2006
Messages
1,128
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2013
  5. 2010
  6. 2007
  7. 2003 or older
Platform
  1. Windows
Too long codes,split it to several subroutines.

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

Regards

Northwolves
 

Kavy

Well-known Member
Joined
Jun 25, 2007
Messages
607
thanks! but splitting into subs, won't speed it up, just make it easier to understand, edit, and read, correct?
 

Kavy

Well-known Member
Joined
Jun 25, 2007
Messages
607
just as a repost for today, anyone else?
Thanks for any suggestions!
 

Kenneth Hobson

Well-known Member
Joined
Feb 6, 2007
Messages
3,181
Office Version
  1. 365
Platform
  1. Windows
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
 

Kavy

Well-known Member
Joined
Jun 25, 2007
Messages
607
thanks for your reply!

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
 

Forum statistics

Threads
1,181,103
Messages
5,928,077
Members
436,587
Latest member
Slicesofquince

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Top