PDA

View Full Version : Clean and speed up code.



stapuff
06-09-2005, 07:24 AM
I am looking to clean and speed up this code (not that it takes very long). I have about 15 macro's I will using for a large program. I need to reduce as much time as possible.

I appreciate everything that can be done.

KurtPublic Sub Button20_Click()

Dim strSourceFolder As String

strSourceFolder = "o:\ow_ftp\"
ChDrive Left$(strSourceFolder, 2)
ChDir strSourceFolder
FName = Application.GetOpenFilename(filefilter:="Text files (*.txt),o:\ow_ftp\*.txt", Title:="Get report to email")
If FName = "False" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.OpenText Filename:=FName, Origin:=xlWindows, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _
Array(3, 1), Array(5, 1), Array(12, 1), Array(20, 1), Array(52, 1), _
Array(63, 1), Array(79, 1), Array(95, 1), Array(106, 1), Array(130, 1))
ChDir "S:\Production Control"
ActiveWorkbook.SaveAs Filename:="S:\Production Control\Production Schedule Download.csv", _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
ActiveWindow.Close
Application.DefaultFilePath = origDefaultPath
Sheets("Download").Select
Range("A2:K5000").ClearContents
Workbooks.Open Filename:="S:\Production Control\Production Schedule Download.csv"
Range("A1:K5000").Copy
Windows("Production Report.xls").Activate
Sheets("Download").Select
Range("A1").PasteSpecial
Windows("Production Schedule Download.csv").Activate
ActiveWindow.Close
Workbooks.Open Filename:="S:\Production Control\Planning Requirements.xls"
Sheets("sheet1").Select
Range("A2:J5000").ClearContents
Windows("Production Report.xls").ActivateSheets("Download").Select
Columns("A:J").EntireColumn.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = False
ActiveSheet.AutoFilterMode = False
Range("A2:J5000").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A2").Select

Dim rng As Range
Set rng = Range("A1:K" & Range("A5000").End(xlUp).Row)
rng.AutoFilter Field:=2, Criteria1:=">1", Operator:=xlOr, Criteria2:="<>0"
On Error Resume Next
With rng
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Err.Clear
ActiveSheet.AutoFilterMode = False
Set rng = Nothing
Set rng = Range("A1:K" & Range("f5000").End(xlUp).Row)
rng.AutoFilter Field:=4, Criteria1:="="
On Error Resume Next
With rng
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Err.Clear
ActiveSheet.AutoFilterMode = False
Set rng = Range("A1:K" & Range("A5000").End(xlUp).Row)
rng.AutoFilter Field:=1, Criteria1:="=Z*", Operator:=xlAnd, Criteria2:="<>ZW"
On Error Resume Next
With rng
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Err.Clear
ActiveSheet.AutoFilterMode = False
Set rng = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Call texttonegative
Kill (FName)
UserForm1.Show
Private Sub texttonegative()

Dim MemberCell As Range

For Each MemberCell In ActiveSheet.UsedRange
If Right(MemberCell.Formula, 1) = "-" Then
MemberCell.Value = -Trim(Left(MemberCell, Len(MemberCell) - 1))
End If
Next

End Sub

Norie
06-09-2005, 08:31 AM
I don't know if it will speed things up but you don't need to select/activate ranges/workbooks/sheets.


Option Explicit
Public Sub Button20_Click()

Dim strSourceFolder As String

strSourceFolder = "o:\ow_ftp\"
ChDrive Left$(strSourceFolder, 2)
ChDir strSourceFolder
FName = Application.GetOpenFilename(filefilter:="Text files (*.txt),o:\ow_ftp\*.txt", Title:="Get report to email")
If FName = "False" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks.OpenText Filename:=FName, Origin:=xlWindows, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _
Array(3, 1), Array(5, 1), Array(12, 1), Array(20, 1), Array(52, 1), _
Array(63, 1), Array(79, 1), Array(95, 1), Array(106, 1), Array(130, 1))
ChDir "S:\Production Control"
ActiveWorkbook.SaveAs Filename:="S:\Production Control\Production Schedule Download.csv", _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
ActiveWindow.Close
Application.DefaultFilePath = origDefaultPath
Sheets("Download").Range("A2:K5000").ClearContents
Workbooks.Open Filename:="S:\Production Control\Production Schedule Download.csv"
Range("A1:K5000").Copy Workbooks("Production Report.xls").Sheets("Download").Range("A1")
Workbooks("Production Schedule Download.csv").Close
Workbooks.Open Filename:="S:\Production Control\Planning Requirements.xls"
Sheets("sheet1").Range("A2:J5000").ClearContents
Workbooks("Production Report.xls").Worksheets("Download").Columns("A:J").EntireColumn.AutoFit
Application.CutCopyMode = False
Application.ScreenUpdating = False
ActiveSheet.AutoFilterMode = False
Range("A2:J5000").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Dim rng As Range
Set rng = Range("A1:K" & Range("A5000").End(xlUp).Row)
rng.AutoFilter Field:=2, Criteria1:=">1", Operator:=xlOr, Criteria2:="<>0"
On Error Resume Next
With rng
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Err.Clear
ActiveSheet.AutoFilterMode = False
Set rng = Nothing
Set rng = Range("A1:K" & Range("f5000").End(xlUp).Row)
rng.AutoFilter Field:=4, Criteria1:="="
On Error Resume Next
With rng
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Err.Clear
ActiveSheet.AutoFilterMode = False
Set rng = Range("A1:K" & Range("A5000").End(xlUp).Row)
rng.AutoFilter Field:=1, Criteria1:="=Z*", Operator:=xlAnd, Criteria2:="<>ZW"
On Error Resume Next
With rng
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Err.Clear
ActiveSheet.AutoFilterMode = False
Set rng = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = False
Call texttonegative
Kill (FName)
UserForm1.Show