Problems with slow code, can this be coded differently to speed it up.

molesy01

New Member
Joined
Dec 23, 2012
Messages
38
Hi

I have a small project that i am developing and its coming along OK. The problem I have is the clunky code I think, it takes to long to populate, its not too bad on my i7 processor but when I move it to my tablet its not quick enough.

I will explain the purpose of the application.

I have a sheet that holds all the data called "MatsData" and a userform called "frmcontract"

There are two listboxes "Listbox1" & "Listbox2" The category name from cell "C" in "MatsData" populates into the "Listbox1" whichever category that is chosen in "Listbox1" is transferred to "Listbox2". When you have completed choosing the categories you hit the + button to create the document; this is where it slows up, I know the code looks complex and it does for me. I had this code written by a friend and he is unavailable to help, I cannot work it out due to my limitations I am relatively new to vba and only pick things up from you good guys, I would appreciate if someone could shed some light on this. How do I attached the file.

Thanks
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
You might get some help if you post your code.
 
Upvote 0
Welcome to the forum. We are here to help.

Without seeing the code, it is hard to tell you how to speed it up.

Here are the standard things to improve speed.
1) Do not select things. Work with the cells rather than a selection object. Avoid code like:
Code:
Cells(1,4).select
selection.value="help"

2) turn off recalculation when doing a lot of work.
Application.Calculation = xlCalculationManual

<do lots="" of="" stuff="">[ do stuff ]

Application.Calculation = xlCalculationAutomatic

3) turn off screen updating
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

<do lots="" of="" stuff="">[ do stuff ]

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True



If you can post the slow code within code tags we can see what is causing it to be slow. It may be that it just has too much to do.</do></do>
 
Upvote 0
Welcome to the forum. We are here to help.

Without seeing the code, it is hard to tell you how to speed it up.

Here are the standard things to improve speed.
1) Do not select things. Work with the cells rather than a selection object. Avoid code like:
Code:
Cells(1,4).select
selection.value="help"

2) turn off recalculation when doing a lot of work.
Application.Calculation = xlCalculationManual

<do lots="" of="" stuff="">[ do stuff ]

Application.Calculation = xlCalculationAutomatic

3) turn off screen updating
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

<do lots="" of="" stuff="">[ do stuff ]

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True



If you can post the slow code within code tags we can see what is causing it to be slow. It may be that it just has too much to do.</do></do>
Code:
'OK here it is




Public Function tabExists(tabName As String) As Boolean
Dim c As Integer
c = 0


While c < Worksheets.Count


  If Worksheets.Item(c + 1).Name = tabName Then
    tabExists = True
    Exit Function
  End If
  c = c + 1
Wend


tabExists = False


End Function
Private Sub btnpop_Click()
  'Sheets.item(0).Remove
   
    
   If Not tabExists("Materials and Workmanship") Then
       Sheets.Add.Name = "Materials and Workmanship"
    Else
      Worksheets("Materials and Workmanship").Cells.Clear
   End If
 
   Dim currentNo As Integer
   Dim hasheader As Boolean
   Dim cnt As Integer
     
    For lngindex = 1 To ListBox2.ListCount
    Dim posindex As Long
    Dim newstr As String
    
    posindex = InStr(1, ListBox2.List(lngindex - 1), "-", vbTextCompare)
    newstr = Mid(ListBox2.List(lngindex - 1), posindex + 1, 2000)
        For Each Item In Worksheets("MatsData").Range("C:C")
            If Item.Value <> "" And Item.Row > 1 And Item.Value = newstr Then
                       
                    For Each item2 In Worksheets("MatsData").Range("D" & Item.Row + 1 & ":D" & Item.Row + 220)
                        If item2.Value <> "" Or Worksheets("MatsData").Range("E" & item2.Row) <> "" Then
                      
                        Dim myval
                        myval = Trim(Worksheets("MatsData").Range("E" & item2.Row).Value)
                        
                        If Worksheets("MatsData").Range("C" & item2.Row - 1) <> "" Then
                            Worksheets("Materials and Workmanship").Range("B" & currentNo + 1).Value = Trim(Item.Value)
                            Worksheets("Materials and Workmanship").Range("A" & currentNo + 1).Value = Trim(Worksheets("MatsData").Cells(item2.Row - 1, Item.Column - 2).Value)
                            Worksheets("Materials and Workmanship").Range("A" & currentNo + 1).Font.Bold = True
                            Worksheets("Materials and Workmanship").Range("B" & currentNo + 1).Font.Bold = True
                            currentNo = currentNo + 1
                        End If
                            
                            Worksheets("Materials and Workmanship").Range("A" & currentNo + 1).Font.Bold = Worksheets("MatsData").Cells(Item.Row, Item.Column - 2).Font.Bold
                        
                            If item2.Value = "" Then
                                'MsgBox (myval)
                                Worksheets("Materials and Workmanship").Range("B" & currentNo + 1).Value = Trim(myval)
                                Worksheets("Materials and Workmanship").Range("B" & currentNo + 1).Font.Bold = True
                            Else
                                Worksheets("Materials and Workmanship").Range("B" & currentNo + 1).Value = Trim(item2.Value)
                            End If
                            
                            Worksheets("Materials and Workmanship").Range("A" & currentNo + 1).Value = Trim(Worksheets("MatsData").Cells(item2.Row, item2.Column - 2).Value)
                            cnt = cnt + 1
                            currentNo = currentNo + 1
                        Else
                            'currentNo = currentNo - 1
                            Exit For
                        End If
                    Next
            End If
        Next
            Worksheets("Materials and Workmanship").Activate
            currentNo = currentNo + 1
Next lngindex
    
    Worksheets("Materials and Workmanship").Range("A1:B" & currentNo).VerticalAlignment = xlVAlignTop
    Worksheets("Materials and Workmanship").Range("A1:B" & currentNo).HorizontalAlignment = xlHAlignLeft
    Worksheets("Materials and Workmanship").Range("A1:B" & currentNo).Columns.AutoFit
    Worksheets("Materials and Workmanship").Range("B:B").ColumnWidth = 80
    Worksheets("Materials and Workmanship").Range("B:B").WrapText = True


 'New margin code, try this
    With ActiveSheet
        .PageSetup.PrintArea = .Range("A1", "B" & currentNo).Address
                With .PageSetup
                    .RightMargin = 10
                    .LeftMargin = 45
                    .TopMargin = 50
                    .BottomMargin = 40
                    '.CenterHeader = "Page # " & lNum & " of " & lTotal
        End With
    End With
    
'CODE BY STEPHEN MOLES
' Puts border for Sheets
    Dim ColumnAB As Range
    Dim Cell As Range
    Set ColumnAB = Range(Range("A1"), Range("B" & currentNo).End(xlUp))
    ColumnAB.Borders.LineStyle = xlLineStyleNone
    ColumnAB.BorderAround Weight:=xlMedium


Range("A65500").Select


    For Each x In ActiveSheet.HPageBreaks
        Dim counter As Integer
        counter = x.Location.Row - 1


        Dim BreakColumn As Range
        Set BreakColumn = Range(Range("A" & counter), Range("B" & counter))
        BreakColumn.Borders(xlEdgeBottom).Weight = xlMedium
        
        Dim NextBreakColumn As Range
        Set BreakColumn = Range(Range("A" & counter + 1), Range("B" & counter + 1))
        BreakColumn.Borders(xlEdgeTop).Weight = xlMedium
        
    Next


       Range("A1").Select
    Unload Me
    Worksheets("Materials and Workmanship").Move After:=Worksheets("MW Cover Sheet")
      Cells.Select
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
   With Range("A1")
  .Value = Date
  .NumberFormat = "dd/mm/yyyy"
                    
       End With
    Range("A1").Select
    End With
End Sub


Private Sub cmdCancel_Click()


Unload Me


End Sub
Private Sub cmdOK_Click()


UpdateContract


Unload Me


End Sub
Private Sub cmdfsh_Click()


Unload Me


End Sub
Private Sub cmddone_Click()


UpdateContract
Unload Me


End Sub
Private Sub cmdmats_Click()
Unload Me
End Sub
Private Sub CommandButton1_Click()
Me.Hide
End Sub


    
'CODE ADDED BY MARK
Private Sub cmdAdd_Click()
    If ListBox1.ListIndex <> -1 Then
        ListBox2.AddItem (ListBox1.Text)
        ListBox1.RemoveItem (ListBox1.ListIndex)
    End If
    
    Dim oListBox As MSForms.ListBox
    Set oListBox = ListBox2
    Call SortListBox(ListBox2, 0, 1, 1)


End Sub


Private Sub cmdRemove_Click()
    If ListBox2.ListIndex <> -1 Then
        ListBox1.AddItem (ListBox2.Text)
        ListBox2.RemoveItem (ListBox2.ListIndex)
    End If
    
    Dim oListBox As MSForms.ListBox
    Set oListBox = ListBox1
    Call SortListBox(ListBox1, 0, 1, 1)
End Sub


Private Sub CommandButton2_Click()
With Range("A1")
  .Value = Date
  .NumberFormat = "dd/mm/yyyy"
                    
   End With
End Sub


Private Sub UserForm_Initialize()
    PopCatCmbo
End Sub


Public Sub PopCatCmbo()
    
    Dim r2 As Integer
        ListBox1.Clear
        intCatNum = 0
        
    For r2 = 1 To 399 Step 1
    If Not Worksheets("MatsData").Range("C" & r2).Value = "" Then
           If r2 > 1 Then 'ignore headers
               ListBox1.AddItem (Worksheets("MatsData").Range("A" & r2).Value & "-" & Worksheets("MatsData").Range("C" & r2).Value)
           End If
    End If
    Next
    


End Sub
    
Sub SortListBox(oLb As MSForms.ListBox, sCol As Integer, sType As Integer, sDir As Integer)
    Dim vaItems As Variant
    Dim i As Long, j As Long
    Dim c As Integer
    Dim vTemp As Variant
     
     'Put the items in a variant array
    vaItems = oLb.List
     
     'Sort the Array Alphabetically(1)
    If sType = 1 Then
        For i = LBound(vaItems, 1) To UBound(vaItems, 1) - 1
            For j = i + 1 To UBound(vaItems, 1)
                 'Sort Ascending (1)
                If sDir = 1 Then
                    If vaItems(i, sCol) > vaItems(j, sCol) Then
                        For c = 0 To oLb.ColumnCount - 1 'Allows sorting of multi-column ListBoxes
                            vTemp = vaItems(i, c)
                            vaItems(i, c) = vaItems(j, c)
                            vaItems(j, c) = vTemp
                        Next c
                    End If
                     
                     'Sort Descending (2)
                ElseIf sDir = 2 Then
                    If vaItems(i, sCol) < vaItems(j, sCol) Then
                        For c = 0 To oLb.ColumnCount - 1 'Allows sorting of multi-column ListBoxes
                            vTemp = vaItems(i, c)
                            vaItems(i, c) = vaItems(j, c)
                            vaItems(j, c) = vTemp
                        Next c
                    End If
                End If
                 
            Next j
        Next i
         'Sort the Array Numerically(2)
         '(Substitute CInt with another conversion type (CLng, CDec, etc.) depending on type of numbers in the column)
    ElseIf sType = 2 Then
        For i = LBound(vaItems, 1) To UBound(vaItems, 1) - 1
            For j = i + 1 To UBound(vaItems, 1)
                 'Sort Ascending (1)
                If sDir = 1 Then
                    If CInt(vaItems(i, sCol)) > CInt(vaItems(j, sCol)) Then
                        For c = 0 To oLb.ColumnCount - 1 'Allows sorting of multi-column ListBoxes
                            vTemp = vaItems(i, c)
                            vaItems(i, c) = vaItems(j, c)
                            vaItems(j, c) = vTemp
                        Next c
                    End If
                     
                     'Sort Descending (2)
                ElseIf sDir = 2 Then
                    If CInt(vaItems(i, sCol)) < CInt(vaItems(j, sCol)) Then
                        For c = 0 To oLb.ColumnCount - 1 'Allows sorting of multi-column ListBoxes
                            vTemp = vaItems(i, c)
                            vaItems(i, c) = vaItems(j, c)
                            vaItems(j, c) = vTemp
                        Next c
                    End If
                End If
                 
            Next j
        Next i
    End If
     
     'Set the list to the array
    oLb.List = vaItems
End Sub
 
Upvote 0
Code:
Public Function tabExists(tabName As String) As Boolean
Dim c As Integer
c = 0


While c < Worksheets.Count


  If Worksheets.Item(c + 1).Name = tabName Then
    tabExists = True
    Exit Function
  End If
  c = c + 1
Wend


tabExists = False


End Function
Private Sub btnpop_Click()
  'Sheets.item(0).Remove
   
    
   If Not tabExists("Materials and Workmanship") Then
       Sheets.Add.Name = "Materials and Workmanship"
    Else
      Worksheets("Materials and Workmanship").Cells.Clear
   End If
 
   Dim currentNo As Integer
   Dim hasheader As Boolean
   Dim cnt As Integer
     
    For lngindex = 1 To ListBox2.ListCount
    Dim posindex As Long
    Dim newstr As String
    
    posindex = InStr(1, ListBox2.List(lngindex - 1), "-", vbTextCompare)
    newstr = Mid(ListBox2.List(lngindex - 1), posindex + 1, 2000)
        For Each Item In Worksheets("MatsData").Range("C:C")
            If Item.Value <> "" And Item.Row > 1 And Item.Value = newstr Then
                       
                    For Each item2 In Worksheets("MatsData").Range("D" & Item.Row + 1 & ":D" & Item.Row + 220)
                        If item2.Value <> "" Or Worksheets("MatsData").Range("E" & item2.Row) <> "" Then
                      
                        Dim myval
                        myval = Trim(Worksheets("MatsData").Range("E" & item2.Row).Value)
                        
                        If Worksheets("MatsData").Range("C" & item2.Row - 1) <> "" Then
                            Worksheets("Materials and Workmanship").Range("B" & currentNo + 1).Value = Trim(Item.Value)
                            Worksheets("Materials and Workmanship").Range("A" & currentNo + 1).Value = Trim(Worksheets("MatsData").Cells(item2.Row - 1, Item.Column - 2).Value)
                            Worksheets("Materials and Workmanship").Range("A" & currentNo + 1).Font.Bold = True
                            Worksheets("Materials and Workmanship").Range("B" & currentNo + 1).Font.Bold = True
                            currentNo = currentNo + 1
                        End If
                            
                            Worksheets("Materials and Workmanship").Range("A" & currentNo + 1).Font.Bold = Worksheets("MatsData").Cells(Item.Row, Item.Column - 2).Font.Bold
                        
                            If item2.Value = "" Then
                                'MsgBox (myval)
                                Worksheets("Materials and Workmanship").Range("B" & currentNo + 1).Value = Trim(myval)
                                Worksheets("Materials and Workmanship").Range("B" & currentNo + 1).Font.Bold = True
                            Else
                                Worksheets("Materials and Workmanship").Range("B" & currentNo + 1).Value = Trim(item2.Value)
                            End If
                            
                            Worksheets("Materials and Workmanship").Range("A" & currentNo + 1).Value = Trim(Worksheets("MatsData").Cells(item2.Row, item2.Column - 2).Value)
                            cnt = cnt + 1
                            currentNo = currentNo + 1
                        Else
                            'currentNo = currentNo - 1
                            Exit For
                        End If
                    Next
            End If
        Next
            Worksheets("Materials and Workmanship").Activate
            currentNo = currentNo + 1
Next lngindex
    
    Worksheets("Materials and Workmanship").Range("A1:B" & currentNo).VerticalAlignment = xlVAlignTop
    Worksheets("Materials and Workmanship").Range("A1:B" & currentNo).HorizontalAlignment = xlHAlignLeft
    Worksheets("Materials and Workmanship").Range("A1:B" & currentNo).Columns.AutoFit
    Worksheets("Materials and Workmanship").Range("B:B").ColumnWidth = 80
    Worksheets("Materials and Workmanship").Range("B:B").WrapText = True


 'New margin code, try this
    With ActiveSheet
        .PageSetup.PrintArea = .Range("A1", "B" & currentNo).Address
                With .PageSetup
                    .RightMargin = 10
                    .LeftMargin = 45
                    .TopMargin = 50
                    .BottomMargin = 40
                    '.CenterHeader = "Page # " & lNum & " of " & lTotal
        End With
    End With
    
'CODE BY STEPHEN MOLES
' Puts border for Sheets
    Dim ColumnAB As Range
    Dim Cell As Range
    Set ColumnAB = Range(Range("A1"), Range("B" & currentNo).End(xlUp))
    ColumnAB.Borders.LineStyle = xlLineStyleNone
    ColumnAB.BorderAround Weight:=xlMedium


Range("A65500").Select


    For Each x In ActiveSheet.HPageBreaks
        Dim counter As Integer
        counter = x.Location.Row - 1


        Dim BreakColumn As Range
        Set BreakColumn = Range(Range("A" & counter), Range("B" & counter))
        BreakColumn.Borders(xlEdgeBottom).Weight = xlMedium
        
        Dim NextBreakColumn As Range
        Set BreakColumn = Range(Range("A" & counter + 1), Range("B" & counter + 1))
        BreakColumn.Borders(xlEdgeTop).Weight = xlMedium
        
    Next


       Range("A1").Select
    Unload Me
    Worksheets("Materials and Workmanship").Move After:=Worksheets("MW Cover Sheet")
      Cells.Select
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
   With Range("A1")
  .Value = Date
  .NumberFormat = "dd/mm/yyyy"
                    
       End With
    Range("A1").Select
    End With
End Sub


Private Sub cmdCancel_Click()


Unload Me


End Sub
Private Sub cmdOK_Click()


UpdateContract


Unload Me


End Sub
Private Sub cmdfsh_Click()


Unload Me


End Sub
Private Sub cmddone_Click()


UpdateContract
Unload Me


End Sub
Private Sub cmdmats_Click()
Unload Me
End Sub
Private Sub CommandButton1_Click()
Me.Hide
End Sub


    
'CODE ADDED BY MARK
Private Sub cmdAdd_Click()
    If ListBox1.ListIndex <> -1 Then
        ListBox2.AddItem (ListBox1.Text)
        ListBox1.RemoveItem (ListBox1.ListIndex)
    End If
    
    Dim oListBox As MSForms.ListBox
    Set oListBox = ListBox2
    Call SortListBox(ListBox2, 0, 1, 1)


End Sub


Private Sub cmdRemove_Click()
    If ListBox2.ListIndex <> -1 Then
        ListBox1.AddItem (ListBox2.Text)
        ListBox2.RemoveItem (ListBox2.ListIndex)
    End If
    
    Dim oListBox As MSForms.ListBox
    Set oListBox = ListBox1
    Call SortListBox(ListBox1, 0, 1, 1)
End Sub


Private Sub CommandButton2_Click()
With Range("A1")
  .Value = Date
  .NumberFormat = "dd/mm/yyyy"
                    
   End With
End Sub


Private Sub UserForm_Initialize()
    PopCatCmbo
End Sub


Public Sub PopCatCmbo()
    
    Dim r2 As Integer
        ListBox1.Clear
        intCatNum = 0
        
    For r2 = 1 To 399 Step 1
    If Not Worksheets("MatsData").Range("C" & r2).Value = "" Then
           If r2 > 1 Then 'ignore headers
               ListBox1.AddItem (Worksheets("MatsData").Range("A" & r2).Value & "-" & Worksheets("MatsData").Range("C" & r2).Value)
           End If
    End If
    Next
    


End Sub
    
Sub SortListBox(oLb As MSForms.ListBox, sCol As Integer, sType As Integer, sDir As Integer)
    Dim vaItems As Variant
    Dim i As Long, j As Long
    Dim c As Integer
    Dim vTemp As Variant
     
     'Put the items in a variant array
    vaItems = oLb.List
     
     'Sort the Array Alphabetically(1)
    If sType = 1 Then
        For i = LBound(vaItems, 1) To UBound(vaItems, 1) - 1
            For j = i + 1 To UBound(vaItems, 1)
                 'Sort Ascending (1)
                If sDir = 1 Then
                    If vaItems(i, sCol) > vaItems(j, sCol) Then
                        For c = 0 To oLb.ColumnCount - 1 'Allows sorting of multi-column ListBoxes
                            vTemp = vaItems(i, c)
                            vaItems(i, c) = vaItems(j, c)
                            vaItems(j, c) = vTemp
                        Next c
                    End If
                     
                     'Sort Descending (2)
                ElseIf sDir = 2 Then
                    If vaItems(i, sCol) < vaItems(j, sCol) Then
                        For c = 0 To oLb.ColumnCount - 1 'Allows sorting of multi-column ListBoxes
                            vTemp = vaItems(i, c)
                            vaItems(i, c) = vaItems(j, c)
                            vaItems(j, c) = vTemp
                        Next c
                    End If
                End If
                 
            Next j
        Next i
         'Sort the Array Numerically(2)
         '(Substitute CInt with another conversion type (CLng, CDec, etc.) depending on type of numbers in the column)
    ElseIf sType = 2 Then
        For i = LBound(vaItems, 1) To UBound(vaItems, 1) - 1
            For j = i + 1 To UBound(vaItems, 1)
                 'Sort Ascending (1)
                If sDir = 1 Then
                    If CInt(vaItems(i, sCol)) > CInt(vaItems(j, sCol)) Then
                        For c = 0 To oLb.ColumnCount - 1 'Allows sorting of multi-column ListBoxes
                            vTemp = vaItems(i, c)
                            vaItems(i, c) = vaItems(j, c)
                            vaItems(j, c) = vTemp
                        Next c
                    End If
                     
                     'Sort Descending (2)
                ElseIf sDir = 2 Then
                    If CInt(vaItems(i, sCol)) < CInt(vaItems(j, sCol)) Then
                        For c = 0 To oLb.ColumnCount - 1 'Allows sorting of multi-column ListBoxes
                            vTemp = vaItems(i, c)
                            vaItems(i, c) = vaItems(j, c)
                            vaItems(j, c) = vTemp
                        Next c
                    End If
                End If
                 
            Next j
        Next i
    End If
     
     'Set the list to the array
    oLb.List = vaItems
End Sub
 
Upvote 0
It appears to me that you are going to be looping and looking at a lot of data that you shouldn't.

For Each Item In Worksheets("MatsData").Range("C:C")

is going to look at eery cell in column C. This is bad enough when there where 65535 cells in Excel but now it is over a million in Excel 2007+ and you are doing it for every item in listbox2 (which I have no idea how many that is) This is probably your biggest slow down.

There are a number of things I would do differently for efficiency but they are trivial.

Also, the last bit of code looks weird but really won't hurt anything.

Code:
    Cells.Select
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
        With Range("A1")
          .Value = Date
          .NumberFormat = "dd/mm/yyyy"
                    
        End With
        Range("A1").Select
    End With

Selects ALL the cells not the used cells. Again in the newer versions of Excel this can be HUGE.

Then the weird bit is that within the "with Selection.Interior" you change what is selected. Since nothing is done after that it won't cause any issue but it is a little weird.


Hope this helps you.
 
Upvote 0

Forum statistics

Threads
1,214,943
Messages
6,122,380
Members
449,080
Latest member
Armadillos

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
Back
Top