VBA Code Efficiency

J

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
834
Hello, Can I make the following code run quicker? Other than run it on the hard drive rather than the OneDrive?

Many thanks.


Code: 
Sub Clean_Data()


Dim myValue As Variant
Dim myValue2 As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim FP As String, FN As String


myValue = InputBox("Enter the railway period, e.g. 1804")
myValue2 = InputBox("Enter the date you wish to clean the data in format yyyy-mm-dd e.g. 2017-06-28")


Workbooks.Open ("C:\Users\jamesco\OneDrive for Business\PMO - Schedule 4 - Sharing best practice\2. CrossCountry Trains\Data\" & myValue & "\Raw\" & myValue2 & ".xlsb")
'Change folder path/file as appropriate


Sheets("Sheet1").Delete


Sheets("Sheet0").Rows("1:5").Delete Shift:=xlUp


Cells.Select
Cells.EntireColumn.AutoFit
Range("J1").ColumnWidth = 10


Application.Calculation = xlAutomatic


Range("J2").FormulaR1C1 = "=IF(MID(RC[-8],3,1)=""5"",1,"""")"
Range("J2").AutoFill Destination:=Range("J2:J" & Sheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row)


With ActiveSheet
  If .AutoFilterMode Then .AutoFilterMode = False
  r = .Range("J" & .Rows.Count).End(xlUp).Row


With .Range("J1").Resize(r)
    .AutoFilter
    If Application.CountIf(.Cells, 1) > 0 Then
        .AutoFilter Field:=1, Criteria1:=1
        .Offset(1).Resize(r - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
  
   End If
   
End With
.AutoFilterMode = False


Range("J2").FormulaR1C1 = "=IF(MID(RC[-8],3,1)=""3"",1,"""")"
Range("J2").AutoFill Destination:=Range("J2:J" & Sheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row)


With ActiveSheet
  If .AutoFilterMode Then .AutoFilterMode = False
  r = .Range("J" & .Rows.Count).End(xlUp).Row


With .Range("J1").Resize(r)
    .AutoFilter
    If Application.CountIf(.Cells, 1) > 0 Then
        .AutoFilter Field:=1, Criteria1:=1
        .Offset(1).Resize(r - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
  
   End If
   
End With
.AutoFilterMode = False


Range("K2").FormulaR1C1 = "=IF(OR(RC[-4]=""NAILSEA B"",RC[-4]=""YATTON"",RC[-4]=""WHITEBALL"",RC[-4]=""MEDOWHALL"",RC[-4]=""NORTNFZWJ"",RC[-4]=""STECHFORD"",RC[-4]=""AISHXOVER"",RC[-4]=""STAPLTNRD""),1,"""")"
Range("K2").AutoFill Destination:=Range("K2:K" & Sheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row)


With ActiveSheet
  If .AutoFilterMode Then .AutoFilterMode = False
  r = .Range("K" & .Rows.Count).End(xlUp).Row


With .Range("K1").Resize(r)
    .AutoFilter
    If Application.CountIf(.Cells, 1) > 0 Then
        .AutoFilter Field:=1, Criteria1:=1
        .Offset(1).Resize(r - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
  
   End If
   
End With
.AutoFilterMode = False


Range("J2").FormulaR1C1 = "=IF(VALUE(RC[-2])<VALUE(""03:00""),RC[-2]+1,VALUE(RC[-2]))"
Range("J2").AutoFill Destination:=Range("J2:J" & Sheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row)


Range("J1") = "Time Value"


    Columns("J:J").Select
    With Selection.Font
        .Name = "Arial"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Range("I1").Select
    Selection.Copy
    Range("J1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False


Dim LastRow As Long, ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet0")
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
 ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=Range( _
 "B2:B" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
 xlSortNormal
 ws.Sort.SortFields.Add Key:=Range( _
 "J2:J" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
 xlSortNormal
  ws.Sort.SortFields.Add Key:=Range( _
 "I2:I" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
 xlSortNormal
 With ws.Sort
 .SetRange Range("A1:O" & LastRow)
 .Header = xlYes
 .MatchCase = False
 .Orientation = xlTopToBottom
 .SortMethod = xlPinYin
 .Apply
 
Columns("K:K").ClearContents


Range("K2").FormulaR1C1 = "=IF(AND(R[-1]C[-2]=""T"",RC[-2]=""A""),1,"""")"
Range("K2").AutoFill Destination:=Range("K2:K" & Sheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row)


With ActiveSheet
  If .AutoFilterMode Then .AutoFilterMode = False
  r = .Range("K" & .Rows.Count).End(xlUp).Row


With .Range("K1").Resize(r)
    .AutoFilter
    If Application.CountIf(.Cells, 1) > 0 Then
        .AutoFilter Field:=1, Criteria1:=1
        .Offset(1).Resize(r - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
  
   End If
   
End With
.AutoFilterMode = False


Columns("K:K").ClearContents


Range("K2").FormulaR1C1 = "=IF(AND(R[-1]C[-2]=""T"",RC[-2]=""A""),1,"""")"
Range("K2").AutoFill Destination:=Range("K2:K" & Sheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row)


With ActiveSheet
  If .AutoFilterMode Then .AutoFilterMode = False
  r = .Range("K" & .Rows.Count).End(xlUp).Row


With .Range("K1").Resize(r)
    .AutoFilter
    If Application.CountIf(.Cells, 1) > 0 Then
        .AutoFilter Field:=1, Criteria1:=1
        .Offset(1).Resize(r - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
  
   End If
   
End With
.AutoFilterMode = False


Columns("K:K").ClearContents


Range("K2").FormulaR1C1 = "=IF(AND(R[-1]C[-2]=""T"",RC[-2]=""D""),1,"""")"
Range("K2").AutoFill Destination:=Range("K2:K" & Sheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row)


With ActiveSheet
  If .AutoFilterMode Then .AutoFilterMode = False
  r = .Range("K" & .Rows.Count).End(xlUp).Row


With .Range("K1").Resize(r)
    .AutoFilter
    If Application.CountIf(.Cells, 1) > 0 Then
        .AutoFilter Field:=1, Criteria1:=1
        .Offset(1).Resize(r - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
  
   End If
   
End With
.AutoFilterMode = False


Columns("K:K").ClearContents


Range("K2").FormulaR1C1 = "=IF(AND(R[-1]C[-2]=""T"",RC[-2]=""D""),1,"""")"
Range("K2").AutoFill Destination:=Range("K2:K" & Sheets("Sheet0").Range("A" & Rows.Count).End(xlUp).Row)


With ActiveSheet
  If .AutoFilterMode Then .AutoFilterMode = False
  r = .Range("K" & .Rows.Count).End(xlUp).Row


With .Range("K1").Resize(r)
    .AutoFilter
    If Application.CountIf(.Cells, 1) > 0 Then
        .AutoFilter Field:=1, Criteria1:=1
        .Offset(1).Resize(r - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
  
   End If
   
End With
.AutoFilterMode = False


End With


End With


End With


End With


End With


End With


End With


End With


    Range("N2").FormulaR1C1 = "=VALUE(RC[-13])"
    Range("N2").Select
    Selection.NumberFormat = "yyyy-mm-dd"
    Range("N2").Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
      
FP = "C:\Users\jamesco\OneDrive for Business\PMO - Schedule 4 - Sharing best practice\2. CrossCountry Trains\Data\" & myValue & "\Cleaned\" & FN
FN = Sheets("Sheet0").Range("N2")
ActiveWorkbook.SaveAs Filename:=FP & Format(FN, "yyyy-mm-dd"), FileFormat:=50
    
ActiveWorkbook.Close


Application.ScreenUpdating = True


MsgBox ("Data Clean Complete")


End Sub
[/HTML][/CODE]
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
You must log in or register to reply here.

Similar threads

O
  • Question
Autofilter no return
Replies
7
Views
163
OX_2005
O
H
  • Solved
Macro to display message end of Code where Col D contains blanks
Replies
7
Views
365
howard
H
I
  • Question
Add button to increment textbox value by 1
2
Replies
13
Views
95
Artik
Artik
R
  • Question
Filter & Delete Deleting Header Row Suddenly
Replies
0
Views
255
reberryjr
R
SunnyAlv
  • Solved
Hidden Rows VBA
Replies
9
Views
412
SunnyAlv
SunnyAlv

Forum statistics

Threads
1,216,170
Messages
6,129,277
Members
449,498
Latest member
Lee_ray

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