I've also had a go at re-formatting your code, declare variables, remove unnecessary selecting, and breaking it down into more manageable procedures. Not saying it is perfect, I would do it quite a bit differently, and not tested, but take a look and see if you can learn anything from it.
Option Explicit
Sub upload_BSI_Data()
Dim importWb As Workbook
Dim docsFolder As String
Dim FileToOpen As String
Dim SourceFileName As String
Dim TemplateName As String
Dim FileDT
Dim Lastrow As Long
Application.ScreenUpdating = False
Application.Calculation = xlAutomatic
docsFolder = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")
TemplateName = ActiveWorkbook.Name
' Get file name
If Worksheets("home").Range("A1") = "Robot" Then
FileToOpen = docsFolder & "\RobotFiles\US_Tasks\US\Daily_Opts_Metrics_Report\Downloaded\data_bsi_Data.xlsx"
Else
'Open dialog box to select source
MsgBox "Select the file"
FileToOpen = Application.GetOpenFilename(Title:="Please choose a file to import")
If Not FileToOpen Then
MsgBox "No file specified.", vbExclamation, "Alert!!!"
Application.ScreenUpdating = True
Exit Sub
End If
End If
' Upload process
' Clear contents in Original Report
ClearFilters Worksheets("Input")
Lastrow = GetLastRow(Worksheets("Input"))
If Lastrow > 1 Then Worksheets("Input").Range("A2:G" & Lastrow).Clear
' Open downloaded file
Set importWb = Workbooks.Open(Filename:=FileToOpen)
Application.Wait Now + #12:00:05 AM#
SourceFileName = importWb.Name
' Copy data from source file
Lastrow = GetLastRow(ActiveSheet)
ActiveSheet.Range("A2:G" & Lastrow).Copy
' Paste data to Apriso Build master file Input tab
Windows(TemplateName).Activate
ActiveSheet.Range("A2").Paste
' Format date in column E
Lastrow = GetLastRow(ActiveSheet)
With ActiveSheet
.Range("E2:E" & Lastrow).NumberFormat = "MM/dd/yyyy"
' Change format of text on Input tab
.Columns("C:C").TextToColumns Destination:=Range("C1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, _
Semicolon:=False, _
Comma:=False, _
Space:=False, _
Other:=False, _
FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
' Auto fit and center all columns
With .Columns("A:J")
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
End With
' Close source file
Application.DisplayAlerts = False
Windows(SourceFileName).Close
Application.DisplayAlerts = True
RemoveCurrentMonth Worksheets("Apriso_Starts_Completes")
CopyToInput Worksheets("Input"), Worksheets("Apriso_Starts_Completes")
' Get date from source file
FileDT = FileDateTime(FileToOpen)
Application.ScreenUpdating = True
' Info for users
Worksheets("home").Range("G9") = FileDT
Worksheets("home").Range("G10") = FileToOpen
' Reset
Application.ScreenUpdating = True
Worksheets("HOME").Range("A1").Select
' Communication to user
If Worksheets("home").Range("A1") <> "Robot" Then MsgBox "Step Completed"
End Sub
Private Function RemoveCurrentMonth(ByRef ws As Worksheet)
' The following removes the current months data from the template in order to update with the latest download
Dim currYear As Long, prevMonth As Long, currMonth As Long, currDay As Long
Dim Lastrow As Long
ClearFilters ws
prevMonth = IIf(Month(Date) = 1, 12, Month(Date) - 1)
currMonth = Month(Date)
currYear = Year(Date)
currDay = Day(Date)
If currDay = 1 Then currMonth = prevMonth & "-" & currYear
With ws
' Filter columns to show current months data and removes to allow for update
.Range("A1").AutoFilter
Lastrow = GetLastRow(ws)
.Range("A1:G" & Lastrow).AutoFilter Field:=5, Criteria1:=xlFilterThisMonth, Operator:=xlFilterDynamic
On Error Resume Next
.Range("$A$1:$G$" & Lastrow).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
On Error GoTo 0
ClearFilters ws
End With
End Function
Public Function CopyToInput(ByRef ws As Worksheet, ByRef source As Worksheet)
Dim inputLastrow As Long, sourceLastrow As Long
' Copy columns to Apriso tab from Input tab
With source
inputLastrow = GetLastRow(ws)
ws.Range("A2:AG" & inputLastrow).Copy
sourceLastrow = GetLastRow(source)
.Range("A" & sourceLastrow + 1).PasteSpecial xlPasteAll
' Auto fit and center all columns
.Columns("A:G").EntireColumn.AutoFit
.Columns("A:G").HorizontalAlignment = xlCenter
End With
' Clear contents in Original Report
With ws
ClearFilters ws
If inputLastrow > 1 Then .Range("A2:G" & inputLastrow).Clear
End With
End Function
Private Function ClearFilters(ByRef ws As Worksheet)
With ws
If .AutoFilterMode = True Then .AutoFilterMode = False
End With
End Function
Private Function GetLastRow(ByRef ws As Worksheet) As Long
With ws
GetLastRow = .Range("A1").Offset(.Rows.Count - 1, 0).End(xlUp).Row
End With
End Function
Reply With Quote
Originally Posted by Danawood
