Help making my VBA code more efficient

P

paulopie

New Member
Joined
Sep 23, 2016
Messages
3
Hi Everyone,

I'm relatively new to using VBA so my technique at the moment is to amend code I find online to suit my needs. I know that this is not an efficient way of doing things and I suspect that I could do the same job in less time (processing time) if I used more efficient VBA. If anyone is willing to help I would be interested if there are some pointers you could give me to make the following more efficient, it would help me in the future too!

Quick explanation of what I am trying to achieve

I take a data dump of survey responses from one of my systems at work, I use the following code to organise and separate satisfied from dissatisfied responses.Each has its own tab in excel. The code bellow is 100% working as I want it but I am sure it could be improved.

There are 3 tabs

Remedy Export, Satisfied Archive, Dissatisfied Archive

The data goes into a table on Rem' Export and is sorted into the other 2 tabs accordingly.




Sub SortingButton_Click()


'*** Turn Screen Updateing Off ***


Application.ScreenUpdating = False


'*** Stop Errors ***


On Error Resume Next


'*** Delete Duplicates On Remedy Export ***
'*** NOT YET COMPLETE ***


'*** Sorting Dissatisfied from Satisfied ***


Dim lr As Long
Dim lr2 As Long
Dim r As Long


lr = Sheets("Remedy Export").Cells(Rows.Count, "A").End(xlUp).Row
lr2 = Sheets("Satisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = Sheets("Dissatisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row


For r = lr To 2 Step -1


If Range("G" & r).Value = "Dissatisfied " Then
Rows(r).Cut Destination:=Sheets("Dissatisfied Archive").Range("A" & lr2 + 1)
lr2 = Sheets("Dissatisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
End If


If Range("G" & r).Value = "Satisfied " Then
Rows(r).Cut Destination:=Sheets("Satisfied Archive").Range("A" & lr3 + 1)
lr3 = Sheets("Satisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
End If

Range("A1").Select


Next r


'*** Resize Satisfied and Dissatisfied Tables ***


Dim StopLeft As String
Dim SrightCol1 As String
Dim SrowCell As String


StopLeft = "$A$5"
SrightCol1 = "M"
SrowCell = "$A$2"

With Sheets("Satisfied Archive")
.ListObjects("Table14").Resize .Range(StopLeft & ":$" & SrightCol1 & "$" & .Range(SrowCell).Value + .Range(StopLeft).Row)


End With


With Sheets("Dissatisfied Archive")
.ListObjects("Table15").Resize .Range(StopLeft & ":$" & SrightCol1 & "$" & .Range(SrowCell).Value + .Range(StopLeft).Row)


End With


'*** Delete Blank Table Rows in Satisfied Archive Tables ***


Dim Srng As Range
Dim Si As Long


Set Srng = ThisWorkbook.Sheets("Satisfied Archive").Range("A1:A10000")


With Srng


For Si = .Rows.Count To 1 Step -1

If .Item(Si) = "" Then
.Item(Si).EntireRow.Delete
End If

Next Si

End With

'*** Delete Blank Table Rows in Dissatisfied Archive Tables ***


Dim Drng As Range
Dim Di As Long


Set Drng = ThisWorkbook.Sheets("Dissatisfied Archive").Range("A1:A10000")


With Drng


For Di = .Rows.Count To 1 Step -1

If .Item(Di) = "" Then
.Item(Di).EntireRow.Delete
End If

Next Di

End With


'*** Delete Blank Table Rows in Remedy Export Tables ***


Dim Rrng As Range
Dim Ri As Long


Set Rrng = ThisWorkbook.Sheets("Remedy Export").Range("A1:A10000")


With Rrng


For Ri = .Rows.Count To 1 Step -1

If .Item(Ri) = "" Then
.Item(Ri).EntireRow.Delete
End If

Next Ri

End With


'*** Turn Screen Updateing On ***


Application.ScreenUpdating = True


End Sub
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Sort by date Sort by votes
Didn't see a whole lot wrong technically. Made some format changes by moving the Dim statements to the top. Deleted a range.Select statement that was superfluous. There is an overkill on variables, but to each his own for that.
Code: 
Sub SortingButton_Click()
 Application.ScreenUpdating = False
 On Error Resume Next
 '*** Delete Duplicates On Remedy Export ***
 '*** NOT YET COMPLETE ***
 '*** Sorting Dissatisfied from Satisfied ***
 Dim lr As Long, lr2 As Long, r As Long
 Dim StopLeft As String, SrightCol1 As String, SrowCell As String
 Dim Srng As Range, Si As Long, Drng As Range, Di As Long, Rrng As Range, Ri As Long
 lr = Sheets("Remedy Export").Cells(Rows.Count, "A").End(xlUp).Row
 lr2 = Sheets("Satisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
 lr3 = Sheets("Dissatisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
 For r = lr To 2 Step -1
    If Range("G" & r).Value = "Dissatisfied " Then
        Rows(r).Cut Destination:=Sheets("Dissatisfied Archive").Range("A" & lr2 + 1)
        lr2 = Sheets("Dissatisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If Range("G" & r).Value = "Satisfied " Then
        Rows(r).Cut Destination:=Sheets("Satisfied Archive").Range("A" & lr3 + 1)
        lr3 = Sheets("Satisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
    End If
 Next r
 '*** Resize Satisfied and Dissatisfied Tables ***
 StopLeft = "$A$5"
 SrightCol1 = "M"
 SrowCell = "$A$2"
    With Sheets("Satisfied Archive")
        .ListObjects("Table14").Resize .Range(StopLeft & ":$" & SrightCol1 & "$" & .Range(SrowCell).Value + .Range(StopLeft).Row)
    End With
    With Sheets("Dissatisfied Archive")
        .ListObjects("Table15").Resize .Range(StopLeft & ":$" & SrightCol1 & "$" & .Range(SrowCell).Value + .Range(StopLeft).Row)
    End With
 '*** Delete Blank Table Rows in Satisfied Archive Tables ***
 Set Srng = ThisWorkbook.Sheets("Satisfied Archive").Range("A1:A10000")
    With Srng
        For Si = .Rows.Count To 1 Step -1
            If .item(Si) = "" Then
                .item(Si).EntireRow.Delete
            End If
        Next Si
    End With
 '*** Delete Blank Table Rows in Dissatisfied Archive Tables ***
 Set Drng = ThisWorkbook.Sheets("Dissatisfied Archive").Range("A1:A10000")
    With Drng
        For Di = .Rows.Count To 1 Step -1
            If .item(Di) = "" Then
                .item(Di).EntireRow.Delete
            End If
        Next Di
    End With
 '*** Delete Blank Table Rows in Remedy Export Tables ***
 Set Rrng = ThisWorkbook.Sheets("Remedy Export").Range("A1:A10000")
    With Rrng
        For Ri = .Rows.Count To 1 Step -1
            If .item(Ri) = "" Then
                .item(Ri).EntireRow.Delete
            End If
        Next Ri
    End With
 '*** Turn Screen Updateing On ***
 Application.ScreenUpdating = True
 End Sub
 
Upvote 0
paulopie said:
Thanks for your help I appreciate it :)
Click to expand...

You're welcome. I have further modified the code to see if it would speed up your execution time. Give it a try.

Code: 
Sub SortingButton_Click()
 Application.ScreenUpdating = False
 On Error Resume Next
 '*** Delete Duplicates On Remedy Export ***
 '*** NOT YET COMPLETE ***
 '*** Sorting Dissatisfied from Satisfied ***
 Dim lr As Long, lr2 As Long, r As Long
 Dim StopLeft As String, SrightCol1 As String, SrowCell As String
 Dim Srng As Range, Si As Long, Drng As Range, Di As Long, Rrng As Range, Ri As Long
 lr = Sheets("Remedy Export").Cells(Rows.Count, "A").End(xlUp).Row
 lr2 = Sheets("Satisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
 lr3 = Sheets("Dissatisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
 For r = lr To 2 Step -1
    If Range("G" & r).Value = "Dissatisfied " Then
        Rows(r).Cut Destination:=Sheets("Dissatisfied Archive").Range("A" & lr2 + 1)
        lr2 = Sheets("Dissatisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
    End If
    If Range("G" & r).Value = "Satisfied " Then
        Rows(r).Cut Destination:=Sheets("Satisfied Archive").Range("A" & lr3 + 1)
        lr3 = Sheets("Satisfied Archive").Cells(Rows.Count, "A").End(xlUp).Row
    End If
 Next r
 '*** Resize Satisfied and Dissatisfied Tables ***
 StopLeft = "$A$5"
 SrightCol1 = "M"
 SrowCell = "$A$2"
    With Sheets("Satisfied Archive")
        .ListObjects("Table14").Resize .Range(StopLeft & ":$" & SrightCol1 & "$" & .Range(SrowCell).Value + .Range(StopLeft).Row)
    End With
    With Sheets("Dissatisfied Archive")
        .ListObjects("Table15").Resize .Range(StopLeft & ":$" & SrightCol1 & "$" & .Range(SrowCell).Value + .Range(StopLeft).Row)
    End With
 '*** Delete Blank Table Rows in Satisfied Archive Tables ***
    With ThisWorkbook.Sheets("Satisfied Archive")
        Set Srng = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
        Srng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
 '*** Delete Blank Table Rows in Dissatisfied Archive Tables ***
    With ThisWorkbook.Sheets("Dissatisfied Archive")
        Set Drng = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
        Drng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
 '*** Delete Blank Table Rows in Remedy Export Tables ***
    With ThisWorkbook.Sheets("Remedy Export")
        Set Rrng = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
        Rrng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
 '*** Turn Screen Updateing On ***
 Application.ScreenUpdating = True
 End Sub
 
Last edited:
Upvote 0
Hi,

Doesn't quite work but I'm going to mess around with it and see if I can see whats going on, I'll let you know what I come up with. Very much appreciate your help Thanks!
 
Upvote 0
You must log in or register to reply here.

Similar threads

TAPS_MikeDion
  • Question Question
Help needed with making a faster, more efficient VBA code
2 3
Replies
21
Views
2K
TAPS_MikeDion
TAPS_MikeDion
E
  • Question Question
VBA code clean up
Replies
9
Views
482
mumps
mumps
L
  • Locked
  • Question Question
Help Cleaning Up Code
Replies
2
Views
576
RoryA
RoryA
M
  • Question Question
Help making code faster
Replies
3
Views
421
michaelsmith559
M
C
  • Solved
VBA Code to move Amount Due from individual sheets to a master sheet, and then copy information from the master sheet back to the individual sheets?
Replies
7
Views
378
Coyotex3
C

Forum statistics

Threads
1,223,234
Messages
6,170,891
Members
452,366
Latest member
TePunaBloke

Share this page

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