4
\$\begingroup\$

This code imports a list of equipment (around 8000), and then filters the errors and creates some lots for the processes that come next. The code is working, but I'm sure it can be improved, especially in terms of performance, as it takes a bit. I think the slowest part is in the "ErrorProcessing" sub.

Any suggestion about how to make it better or better practises when coding vba would be much appreciated. As an extra, I tried to put a userform with an animation while the process is going on, but it's not showing anything, so I commented that part. Any ideas?

Sub Import_data()

Dim FilePath As Variant, FileName As Variant, TempSheetName As String, k As Integer, n As Integer, RegisterNumb As Integer, RegisterNoError As Integer, Errors As Integer, i As Integer
Dim LastRow As Long
Dim ThisWorBookName As String, PathWorkbook As String, ProjectName As String
Dim AreaName As String, Areacode As String, AreaNumber As String
Dim wsCon As Worksheet, wsLot As Worksheet, wsReg As Worksheet

Set wsCon = Sheets("CONTROL")
Set wsLot = Sheets("LOTS")

Call PageVisibility(1)

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

ThisWorkBookName = ActiveWorkbook.Name
PathWorkbook = Application.ThisWorkbook.Path & "\"
ProjectName = Left(wsCon.Cells(4, 3).Value, 8) & "_" & (Format(wsCon.Cells(5, 3).Value, "yyyy_mm_dd"))

ChDir PathWorkbook

'Check if Project exist
var1 = Application.ThisWorkbook.Path & "\"
var2 = Left(wsCon.Cells(4, 3).Value, 8) & "_" & (Format(wsCon.Cells(5, 3).Value, "yyyy_mm_dd"))
sFolderpath = var1 & var2

If Dir(var1 & var2, vbDirectory) <> "" Then

Else
    Result = MsgBox("Project " & var2 & " Does not exist." & vbNewLine & vbNewLine & "Do You want to Create it?", vbYesNo + vbExclamation)
    If Result = 6 Then
        Call CreateProjects
    Else
     
    MsgBox "You Need to create the project before Importing the records", vbExclamation
    Exit Sub
                           
    End If
    
End If

wsLot.Range("B5:D5").Value = 0
wsLot.Range("D9:E100").Delete Shift:=xlUp

TempSheetName = "REGISTER"
   
'Check that workbook is reset

For Each Sheet In Worksheets
    If TempSheetName = UCase(Sheet.Name) Then
      
    MsgBox "Reset before importing"
    Exit Sub
    End If
Next Sheet

'File opening

FilePath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")
If FilePath = False Then Exit Sub

'Animated.Show vbModeless
'Application.Wait (Now + TimeValue("0:00:05"))
'DoEvents

FileName = Mid$(FilePath, InStrRev(FilePath, "\") + 1, Len(FilePath))

ControlFile = ActiveWorkbook.Name
Workbooks.Open FileName:=FilePath
Sheets("REGISTER").Copy After:=Workbooks(ControlFile).Sheets("LOTEVAL")
Windows(FileName).Activate
ActiveWorkbook.Close SaveChanges:=False
Windows(ControlFile).Activate

'Formulas to values

Set wsReg = Sheets("REGISTER")

wsReg.Unprotect

wsReg.Range("B:B").Value = wsReg.Range("B:B").Value
wsReg.Range("V:V").Value = wsReg.Range("V:V").Value
wsReg.Range("Y:Y").Value = wsReg.Range("Y:Y").Value

LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row

RegisterNumb = LastRow - 6
RegisterNoError = RegisterNumb

wsLot.Cells(5, "C").Value = RegisterNoError
wsLot.Cells(5, "D").Value = RegisterNumb

'Error Filtering
'--------------------

Call ErrorPorcessing

RegisterNoError = wsLot.Cells(5, "C").Value

'Order
'------------

Call PutSomeOrder(LastRow)

'Main Areas creation
'-------------------

wsLot.Range("A9").Formula2R1C1 = "=UNIQUE(FILTER(REGISTER!R7C3:R65536C3,REGISTER!R7C3:R65536C3<>""""))"

'Lot assignement
'---------------

n = 6 + RegisterNoError

For k = 7 To n
AreaNumber = wsLot.Cells(5, 1).Value

If wsReg.Cells(k, "B").Value > 0 Then
    
    If wsReg.Cells(k, "B").Value = wsReg.Cells((k - 1), "B").Value Then
        wsReg.Cells(k, "AA").Value = wsReg.Cells((k - 1), "AA").Value
    Else
        For i = 9 To AreaNumber + 8
            If wsReg.Range("C" & k).Value = wsLot.Range("A" & i) Then wsReg.Cells(k, "AA").Value = wsLot.Range("C" & i)
        Next i
    End If

wsReg.Cells(k, "AB").Value = wsReg.Cells(k, "H").Value
wsReg.Cells(k, "AC").Value = wsReg.Cells(k, "V").Value
wsReg.Cells(k, "AD").Value = wsReg.Cells(k, "AA").Value & "_" & wsReg.Cells(k, "AB").Value & "_" & wsReg.Cells(k, "AC").Value

End If

Next k

n = 8 + wsLot.Cells(5, "A").Value

wsLot.Cells(9, "E").Value = 7

For k = 9 To n

wsLot.Cells(k, "D").Value = WorksheetFunction.CountIf(wsReg.Range("AA:AA"), wsLot.Cells(k, "C").Value)

If k > 9 Then wsLot.Cells(k, "E").Value = wsLot.Cells(k - 1, "E").Value + wsLot.Cells(k - 1, "D").Value

Next k

wsLot.Cells(5, "C").Value = WorksheetFunction.CountA(wsReg.Range("AA:AA"))

wsLot.Range("G9").Formula2R1C1 = "=UNIQUE(FILTER(REGISTER!R7C30:R12000C30,REGISTER!R7C30:R12000C30<>""""))"
wsLot.Range("E5").Formula = "=IFERROR(IF(G9<>"""",COUNTA(G9#),0),0)"
wsLot.Range("Q9").Formula2R1C1 = "=UNIQUE(FILTER(REGISTER!R7C30:R12000C30,REGISTER!R7C30:R12000C30<>""""))"
wsLot.Range("R9").Formula2R1C1 = "UNIQUE(FILTER(R:R,R:R<>""""))"

n = 8 + wsLot.Cells(5, "E").Value

wsLot.Cells(9, "E").Value = 7

For k = 9 To n

wsLot.Cells(k, "H").Value = WorksheetFunction.CountIf(wsReg.Range("AD:AD"), wsLot.Cells(k, "G").Value)

Next k

wsLot.Range("H8").Formula = "=MAX(H9:H3000)"

Calculate

If wsLot.Range("H8").Value > 3200 Then MsgBox "Warning, at least one of the lots has more than 32000 elements"

'Export errors and Registers to Project Folder

Call ExportErrorsAndRegisters

RegisterNumb = wsLot.Range("D5").Value
RegisterNoError = wsLot.Range("C5").Value
Errors = wsLot.Range("B5").Value
wsCon.Range("O3").Value = 1
wsCon.Activate

MsgBox ("Ex DataBase Import Completed" & vbNewLine & vbNewLine _
& "TOTAL EQUIPMENT IN Ex DATABASE :  " & RegisterNumb & vbNewLine _
& "EQUIPMENT EXCLUDED DUE TO ERROR :  " & Errors & vbNewLine _
& "TOTAL EQUIPMENT IMPORTED :  " & RegisterNoError & vbNewLine & vbNewLine _
& "The Equipment with errors have been recorded on the ERRROR_LOG. You can continue discarting those elements or correct them in the originalfile and do the Import again." & vbNewLine)


'Save for Navigation
    
ActiveWorkbook.SaveAs PathWorkbook & ProjectName & "\NAV\" & ProjectName & "_Step_1.exp", FileFormat:=52
ActiveWorkbook.SaveAs PathWorkbook & ProjectName & "\" & ProjectName & ".exp", FileFormat:=52
ActiveWorkbook.SaveAs PathWorkbook & ThisWorkBookName, FileFormat:=52
    
    
Call PageVisibility(2)
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

'Unload Animated

Sheets("LOTEVAL").Activate
wsCon.Activate

End Sub

Sub ErrorPorcessing()

Dim WSActual As Worksheet, WSError As Worksheet
Dim ErrorLastRow As Long, ErrorLastRowPrev As Long, ThisCatErrors As Long
Dim k As Integer, tempvar As Variant
Dim wsCon As Worksheet, wsLot As Worksheet, wsReg As Worksheet, wsErr As Worksheet

Set wsCon = Sheets("CONTROL")
Set wsLot = Sheets("LOTS")
Set wsReg = Sheets("REGISTER")

Set WSActual = ActiveSheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual


'Check if ERROR exists, and if so, delete it
For Each Sheet In ActiveWorkbook.Worksheets
     If Sheet.Name = "ERROR" Then
          Application.DisplayAlerts = False
          Sheet.Delete
          Application.DisplayAlerts = True
     End If
Next Sheet

'Create ERROR Sheet

Set WSError = Sheets("ERRORT")
 
WSError.Copy Before:=wsCon
ActiveSheet.Name = "ERROR"
Set WSError = ActiveSheet

Set wsErr = Sheets("ERROR")

wsErr.Cells(2, 2).Value = "REGISTERS WITH ERRORS"
wsErr.Cells(5, 23).Value = "ERROR CODE"

ErrorLastRowPrev = 6
ErrorLastRow = 6

'Clear any existing filters
  On Error Resume Next
    wsReg.ShowAllData
  On Error GoTo 0

'Identify the Errors for Zone, Discipline and Ex Certificate

For k = 7 To (wsLot.Cells(5, 3).Value + 6)

wsReg.Activate

tempvar = wsReg.Range("H" & k).Value

If tempvar = "Z0" Or tempvar = "Z1" Or tempvar = "Z2" Then
wsReg.Range("Y" & k).Value = "OK"
Else
wsReg.Range("Y" & k).Value = "FAIL"
End If

tempvar = wsReg.Range("T" & k).Value

If tempvar = "Instrument" Or tempvar = "Electrical" Then
wsReg.Range("Z" & k).Value = "OK"
Else
wsReg.Range("Z" & k).Value = "FAIL"
End If

tempvar = wsReg.Range("U" & k).Value

If tempvar = "Ex d" Or tempvar = "Ex e" Or tempvar = "Ex n" Or tempvar = "Ex p" Or tempvar = "Ex i" Then
wsReg.Range("AA" & k).Value = "OK"
Else
wsReg.Range("AA" & k).Value = "FAIL"
End If

tempvar = wsReg.Range("V" & k).Value

If tempvar = "High" Or tempvar = "Medium" Or tempvar = "Low" Then
wsReg.Range("AB" & k).Value = "OK"
Else
wsReg.Range("AB" & k).Value = "FAIL"
End If


Next k

'Filter the rows with errors
Application.DisplayAlerts = False

On Error Resume Next
With wsReg.Range("A7:AD" & wsLot.Cells(5, 3).Value)
    .AutoFilter Field:=2, Criteria1:="="
    .SpecialCells(xlCellTypeVisible).Cells.Copy
    wsErr.Rows(ErrorLastRow + 1).PasteSpecial
    .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
On Error GoTo 0

'Clear any existing filters
  On Error Resume Next
    wsReg.ShowAllData
  On Error GoTo 0

'Recalculate ErrorLastRow

ErrorLastRow = wsErr.Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row

If ErrorLastRow < ErrorLastRowPrev Then
'No Errors
ErrorLastRow = ErrorLastRowPrev
ThisCatErrors = ErrorLastRow - ErrorLastRowPrev
Else
'Errors
ThisCatErrors = ErrorLastRow - ErrorLastRowPrev
wsErr.Range("W" & (ErrorLastRowPrev + 1) & ":W" & ErrorLastRow).Value = "Id or record Missing"
wsLot.Cells(5, 3).Value = wsLot.Cells(5, 3).Value - (ThisCatErrors)
ErrorLastRowPrev = ErrorLastRow
End If

'Zone Errors
On Error Resume Next
With wsReg.Range("A7:AD" & wsLot.Cells(5, 3).Value)
    .AutoFilter Field:=25, Criteria1:="FAIL"
    .SpecialCells(xlCellTypeVisible).Cells.Copy
    wsErr.Rows(ErrorLastRow + 1).PasteSpecial
    .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
On Error GoTo 0

'Clear any existing filters
  On Error Resume Next
    wsReg.ShowAllData
  On Error GoTo 0

ErrorLastRow = wsErr.Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row

If ErrorLastRow < ErrorLastRowPrev + 1 Then
'No Errors
ErrorLastRow = ErrorLastRowPrev
ThisCatErrors = ErrorLastRow - ErrorLastRowPrev
Else
'Errors
ThisCatErrors = ErrorLastRow - ErrorLastRowPrev
wsErr.Range("W" & (ErrorLastRowPrev + 1) & ":W" & ErrorLastRow).Value = "Zone Field not valid"
wsLot.Cells(5, 3).Value = wsLot.Cells(5, 3).Value - (ThisCatErrors)
ErrorLastRowPrev = ErrorLastRow
End If


'Discipline Errors
On Error Resume Next
With wsReg.Range("A7:AD" & wsLot.Cells(5, 3).Value)
    .AutoFilter Field:=26, Criteria1:="FAIL"
    .SpecialCells(xlCellTypeVisible).Cells.Copy
    wsErr.Rows(ErrorLastRow + 1).PasteSpecial
    .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
On Error GoTo 0

'Clear any existing filters
  On Error Resume Next
    wsReg.ShowAllData
  On Error GoTo 0

'Recalculate ErrorLastRow
ErrorLastRow = wsErr.Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row

If ErrorLastRow < ErrorLastRowPrev + 1 Then
'Cero Errores
ErrorLastRow = ErrorLastRowPrev
ThisCatErrors = ErrorLastRow - ErrorLastRowPrev
Else
'Hay Errores
ThisCatErrors = ErrorLastRow - ErrorLastRowPrev
wsErr.Range("W" & (ErrorLastRowPrev + 1) & ":W" & ErrorLastRow).Value = "Discipline not valid"
wsLot.Cells(5, 3).Value = wsLot.Cells(5, 3).Value - (ThisCatErrors)
ErrorLastRowPrev = ErrorLastRow
End If


'Errores de Ex cert
On Error Resume Next
With wsReg.Range("A7:AD" & wsLot.Cells(5, 3).Value)
    .AutoFilter Field:=27, Criteria1:="FAIL"
    .SpecialCells(xlCellTypeVisible).Cells.Copy
    wsErr.Rows(ErrorLastRow + 1).PasteSpecial
    .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
On Error GoTo 0

'Clear any existing filters
  On Error Resume Next
    wsReg.ShowAllData
  On Error GoTo 0

'Recalculate ErrorLastRow
ErrorLastRow = wsErr.Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row

If ErrorLastRow < ErrorLastRowPrev + 1 Then
'No Errors
ErrorLastRow = ErrorLastRowPrev
ThisCatErrors = ErrorLastRow - ErrorLastRowPrev
Else
'Errores
ThisCatErrors = ErrorLastRow - ErrorLastRowPrev
wsErr.Range("W" & (ErrorLastRowPrev + 1) & ":W" & ErrorLastRow).Value = "Ex protection type not valid"
wsLot.Cells(5, 3).Value = wsLot.Cells(5, 3).Value - (ThisCatErrors)
ErrorLastRowPrev = ErrorLastRow
End If

'Risk Level Errors
On Error Resume Next
With wsReg.Range("A7:AD" & wsLot.Cells(5, 3).Value)
    .AutoFilter Field:=28, Criteria1:="FAIL"
    .SpecialCells(xlCellTypeVisible).Cells.Copy
    wsErr.Rows(ErrorLastRow + 1).PasteSpecial
    .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
On Error GoTo 0

'Clear any existing filters
  On Error Resume Next
    wsReg.ShowAllData
  On Error GoTo 0

'Recalculate ErrorLastRow
ErrorLastRow = wsErr.Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row

If ErrorLastRow < ErrorLastRowPrev + 1 Then
'No Errors
ErrorLastRow = ErrorLastRowPrev
ThisCatErrors = ErrorLastRow - ErrorLastRowPrev
Else
'Errors
ThisCatErrors = ErrorLastRow - ErrorLastRowPrev
wsErr.Range("W" & (ErrorLastRowPrev + 1) & ":W" & ErrorLastRow).Value = "Risk level not valid"
wsLot.Cells(5, 3).Value = wsLot.Cells(5, 3).Value - (ThisCatErrors)
ErrorLastRowPrev = ErrorLastRow
End If

wsLot.Cells(5, "B").Value = ErrorLastRow - 6

'End

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
WSActual.Activate

End Sub

Sub PutSomeOrder(LastRow2 As Long)

Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("REGISTER")

    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("C7"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("H7"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("T7"), Order:=xlAscending
        .SetRange ws.Range("A7:AH" & LastRow2)
        .Apply
    End With

End Sub
\$\endgroup\$
6
\$\begingroup\$

Before considering performance...some comments from reviewing the code.

  1. (Best Practice) Use Option Explicit at the top of the module. This forces the requirement for all variables and constants to be declared. Consequently, it can identify typos like Dim ThisWorBookName As String (found in the code) when Dim ThisWorkBookName As String was intended. Declaring variables at the top of a procedure is better than not declaring them at all. Better still is declaring them closer to where they are first used.
  2. (Deprecated) Call is no longer required to call procedures. It can be removed.
  3. Sub Import_data() is a fairly lengthy subroutine. Notice how comments are required throughout to identify what 'task' is being performed by various blocks of code. Your code can become somewhat self-documenting by creating and calling procedures that are named for the task. This will will make all your subroutines easier to read, debug, and instrument in order to find what operations are taking the longest time. Doing this applies the Single Responsibility Principle (SRP): Each Subroutine and Function should accomplish a single task...or put another way, each Subroutine and Function should have a single 'reason to change'. (Easier said than done...but it is something for your code to aspire to).
  4. Apply the Don't Repeat Yourself (DRY) principle. There is a lot of repeated statements and code blocks that vary only by a single parameter. The repeated blocks can be eliminated by extracting the logic into focused subroutines and functions.
  5. Give variable names a meaningful identifier. Using an abbreviation is not going to make your code faster (or slower)...but abbreviations and single character variable names will definitely be require more time and effort to understand when you come back to this code (for whatever reason) months later.
  6. There are many references to cells using constant row and column identifiers. For example wsLot.Cells(5, "C") is a particular favorite. It is referred to often using different row and cell constants: wsLot.Cells(5,3), wsLot.Cells("C5") This cell is consistently associated with the variable RegisterNoError. Consider adding a module Property by the same name and removing the variable altogether.

Same applies to: Worksheets("LOTS").Cells(5, "D") => RegisterNumb (use the full name?) Worksheets("LOTS").Cells(5, 1) => AreaNumber In fact, there appears to be a number of important cells in row 5 of Worksheets("LOTS"). I've deciphered 3...Give them all names/properties and your code becomes more readable (and consistent). Other similar opportunities: Worksheets("CONTROL").Cells(4,3) and Worksheets("CONTROL").Cells(5,3). Another option for consistency and easy interpretation is using NamedRanges.

  1. Magic Numbers - there are many cases where numeric literals are used within the code. It is nearly impossible to figure out what they mean. If they can be given a name, then declare them as constants. For example, '6' is used in many places. My guess is that it is an important offset from something. Declare a module constant with a meaningful name: Private Const IMPORTANT_OFFSET As Long = 6 (you can pick a better name). Other frequently used magic numbers in the code are 7 and 9. What do they mean?...give them a name. Magic numbers also make their way into hard coded formula strings - build the formula strings using the constant(s) there as well. When the need arises to change these magic numbers, you only have to modify the declaration rather than hunt through your code and hope that you've updated them all (spoiler alert: you haven't). Note: column value string literals within Range or Cell calls are essentially 'magic numbers' as well and can possibly be declared as constant string values with names that provide more meaning.
  2. Finally - performance. Not sure what you would consider fast or slow, but one way to determine where the code is 'slowest' is to log timestamps and see where bottlenecks might exist. They are often not where you expect. So, log timestamp subroutine calls throughout your code and you will know where to spend your effort. Before and after a section of code you deem significant call a logging procedure...something like.
Private Sub LogTime(message As String)
   Dim timestamp As String, logEntry As String
   timestamp = Format(Now, "mm/dd/yyyy HH:mm:ss")
   logEntry = message & ": " & timestamp
   'Append logEntry to a text file or write them out to an excel sheet 
End Sub

Below is the module refactored using some of the ideas described above. I had to stub a few procedures to get the original code to compile - so obviously, the code below does not work.

Option Explicit

Private Const IMPORTANT_OFFSET As Long = 6

Private Property Get RegisterNoError() As Long
    RegisterNoError = Worksheets("LOTS").Range("C5").value
End Property

Private Property Let RegisterNoError(value As Long)
    Worksheets("LOTS").Range("C5").value = value
End Property

Private Property Get RegisterNumb() As Long
    RegisterNoError = Worksheets("LOTS").Range("D5").value
End Property

Private Property Let RegisterNumb(value As Long)
    Worksheets("LOTS").Range("D5").value = value
End Property

Sub Import_data()

Dim FilePath As Variant, FileName As Variant, TempSheetName As String, k As Integer, n As Integer, Errors As Integer, i As Integer
Dim LastRow As Long
Dim PathWorkbook As String, ProjectName As String
Dim AreaName As String, Areacode As String, AreaNumber As String
Dim wsCon As Worksheet, wsLot As Worksheet, wsReg As Worksheet

Set wsCon = Sheets("CONTROL")
Set wsLot = Sheets("LOTS")

PageVisibility (1) 'Not declared - I've added stub so that this subroutine can compile

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim ThisWorkBookName As String 'Identified when Option Explicit was added
ThisWorkBookName = ActiveWorkbook.Name

PathWorkbook = Application.ThisWorkbook.Path & "\"
ProjectName = Left(wsCon.Cells(4, 3).value, 8) & "_" & (Format(wsCon.Cells(5, 3).value, "yyyy_mm_dd"))

ChDir PathWorkbook

'Check if Project exist
Dim var1 As String 'Identified when Option Explicit was added
Dim var2 As String 'Identified when Option Explicit was added

var1 = Application.ThisWorkbook.Path & "\"
var2 = Left(wsCon.Cells(4, 3).value, 8) & "_" & (Format(wsCon.Cells(5, 3).value, "yyyy_mm_dd"))

If Dir(var1 & var2, vbDirectory) = "" Then
    Dim Result As Long
    Result = MsgBox("Project " & var2 & " Does not exist." & vbNewLine & vbNewLine & "Do You want to Create it?", vbYesNo + vbExclamation)
    If Result = 6 Then
        CreateProjects 'Is not declared - added a stub to make the module compile
    Else
     
    MsgBox "You Need to create the project before Importing the records", vbExclamation
    Exit Sub
                           
    End If
    
End If

wsLot.Range("B5:D5").value = 0
wsLot.Range("D9:E100").Delete Shift:=xlUp

TempSheetName = "REGISTER"
   
'Check that workbook is reset

Dim Sheet As Worksheet
For Each Sheet In Worksheets
    If TempSheetName = UCase(Sheet.Name) Then
      
    MsgBox "Reset before importing"
    Exit Sub
    End If
Next Sheet

'File opening

FilePath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")
If FilePath = False Then Exit Sub

'Animated.Show vbModeless
'Application.Wait (Now + TimeValue("0:00:05"))
'DoEvents

FileName = Mid$(FilePath, InStrRev(FilePath, "\") + 1, Len(FilePath))

Dim ControlFile As String
ControlFile = ActiveWorkbook.Name
Workbooks.Open FileName:=FilePath
Sheets("REGISTER").Copy After:=Workbooks(ControlFile).Sheets("LOTEVAL")
Windows(FileName).Activate
ActiveWorkbook.Close SaveChanges:=False
Windows(ControlFile).Activate

'Formulas to values

Set wsReg = Sheets("REGISTER")

wsReg.Unprotect

wsReg.Range("B:B").value = wsReg.Range("B:B").value '<--Copies self(?)
wsReg.Range("V:V").value = wsReg.Range("V:V").value '<--Copies self(?)
wsReg.Range("Y:Y").value = wsReg.Range("Y:Y").value '<--Copies self(?)

LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row

RegisterNumb = LastRow - IMPORTANT_OFFSET
RegisterNoError = RegisterNumb

'Error Filtering
'--------------------

ErrorProcessing 'fixed typo

'Order
'------------

PutSomeOrder LastRow

'Main Areas creation
'-------------------

wsLot.Range("A9").Formula2R1C1 = "=UNIQUE(FILTER(REGISTER!R7C3:R65536C3,REGISTER!R7C3:R65536C3<>""""))"

'Lot assignement
'---------------

n = IMPORTANT_OFFSET + RegisterNoError

For k = 7 To n
AreaNumber = wsLot.Cells(5, 1).value 'Assign this outside the loop, it is not modified in the loop or depend on k

If wsReg.Cells(k, "B").value > 0 Then
    
    If wsReg.Cells(k, "B").value = wsReg.Cells((k - 1), "B").value Then
        wsReg.Cells(k, "AA").value = wsReg.Cells((k - 1), "AA").value
    Else
        For i = 9 To AreaNumber + 8
            If wsReg.Range("C" & k).value = wsLot.Range("A" & i) Then wsReg.Cells(k, "AA").value = wsLot.Range("C" & i)
        Next i
    End If

wsReg.Cells(k, "AB").value = wsReg.Cells(k, "H").value
wsReg.Cells(k, "AC").value = wsReg.Cells(k, "V").value
wsReg.Cells(k, "AD").value = wsReg.Cells(k, "AA").value & "_" & wsReg.Cells(k, "AB").value & "_" & wsReg.Cells(k, "AC").value

End If

Next k

n = 8 + wsLot.Cells(5, "A").value

wsLot.Cells(9, "E").value = 7

For k = 9 To n

wsLot.Cells(k, "D").value = WorksheetFunction.CountIf(wsReg.Range("AA:AA"), wsLot.Cells(k, "C").value)

If k > 9 Then wsLot.Cells(k, "E").value = wsLot.Cells(k - 1, "E").value + wsLot.Cells(k - 1, "D").value

Next k

RegisterNoError = WorksheetFunction.CountA(wsReg.Range("AA:AA"))

wsLot.Range("G9").Formula2R1C1 = "=UNIQUE(FILTER(REGISTER!R7C30:R12000C30,REGISTER!R7C30:R12000C30<>""""))"
wsLot.Range("E5").Formula = "=IFERROR(IF(G9<>"""",COUNTA(G9#),0),0)"
wsLot.Range("Q9").Formula2R1C1 = "=UNIQUE(FILTER(REGISTER!R7C30:R12000C30,REGISTER!R7C30:R12000C30<>""""))"
wsLot.Range("R9").Formula2R1C1 = "UNIQUE(FILTER(R:R,R:R<>""""))"

n = 8 + wsLot.Cells(5, "E").value

wsLot.Cells(9, "E").value = 7

For k = 9 To n

wsLot.Cells(k, "H").value = WorksheetFunction.CountIf(wsReg.Range("AD:AD"), wsLot.Cells(k, "G").value)

Next k

wsLot.Range("H8").Formula = "=MAX(H9:H3000)"

Calculate

If wsLot.Range("H8").value > 3200 Then MsgBox "Warning, at least one of the lots has more than 32000 elements"

'Export errors and Registers to Project Folder
ExportErrorsAndRegistersToProjectFolder 'no longer a need for the above comment (#3)

Errors = wsLot.Range("B5").value
wsCon.Range("O3").value = 1
wsCon.Activate

MsgBox ("Ex DataBase Import Completed" & vbNewLine & vbNewLine _
& "TOTAL EQUIPMENT IN Ex DATABASE :  " & RegisterNumb & vbNewLine _
& "EQUIPMENT EXCLUDED DUE TO ERROR :  " & Errors & vbNewLine _
& "TOTAL EQUIPMENT IMPORTED :  " & RegisterNoError & vbNewLine & vbNewLine _
& "The Equipment with errors have been recorded on the ERRROR_LOG. You can continue discarting those elements or correct them in the originalfile and do the Import again." & vbNewLine)


'Save for Navigation
    
ActiveWorkbook.SaveAs PathWorkbook & ProjectName & "\NAV\" & ProjectName & "_Step_1.exp", FileFormat:=52
ActiveWorkbook.SaveAs PathWorkbook & ProjectName & "\" & ProjectName & ".exp", FileFormat:=52
ActiveWorkbook.SaveAs PathWorkbook & ThisWorkBookName, FileFormat:=52
    
    
Call PageVisibility(2)
    
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

'Unload Animated

Sheets("LOTEVAL").Activate
wsCon.Activate

End Sub

Sub ErrorProcessing()

Dim WSActual As Worksheet, WSError As Worksheet
Dim k As Integer, tempvar As Variant
Dim wsCon As Worksheet, wsLot As Worksheet, wsReg As Worksheet, wsErr As Worksheet

Set wsCon = Sheets("CONTROL")
Set wsLot = Sheets("LOTS")
Set wsReg = Sheets("REGISTER")

Set WSActual = ActiveSheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual


'Check if ERROR exists, and if so, delete it
Dim Sheet As Worksheet
For Each Sheet In ActiveWorkbook.Worksheets
     If Sheet.Name = "ERROR" Then
          Application.DisplayAlerts = False
          Sheet.Delete
          Application.DisplayAlerts = True
     End If
Next Sheet

'Create ERROR Sheet

Set WSError = Sheets("ERRORT") '<--Typo?
 
WSError.Copy Before:=wsCon
ActiveSheet.Name = "ERROR"
Set WSError = ActiveSheet

Set wsErr = Sheets("ERROR")

wsErr.Cells(2, 2).value = "REGISTERS WITH ERRORS"
wsErr.Cells(5, 23).value = "ERROR CODE"

ClearAnyExistingFilters wsReg ' - DRY (#4)

'Identify the Errors for Zone, Discipline and Ex Certificate

For k = 7 To RegisterNoError + IMPORTANT_OFFSET

    wsReg.Activate
    
    LoadOKFail MeetsSuccessCriteria1(wsReg.Range("H" & k).value), wsReg, "Y", k ' - DRY (#4)
    
    LoadOKFail MeetsSuccessCriteria2(wsReg.Range("T" & k).value), wsReg, "Z", k ' - DRY (#4)
    
    LoadOKFail MeetsSuccessCriteria3(wsReg.Range("U" & k).value), wsReg, "AA", k ' - DRY (#4)
    
    LoadOKFail MeetsSuccessCriteria4(wsReg.Range("V" & k).value), wsReg, "AB", k ' - DRY (#4)

Next k

'Filter the rows with errors
Application.DisplayAlerts = False

Dim ErrorLastRowPrev As Long
ErrorLastRowPrev = IMPORTANT_OFFSET

EvaluateField wsLot, wsReg, wsErr, 2, ErrorLastRowPrev ' - DRY (#4)

ErrorLastRowPrev = HandleErrors(ErrorLastRowPrev - 1, wsErr, wsLot, "Id or record Missing")  ' - DRY (#4)

'Zone Errors
EvaluateField wsLot, wsReg, wsErr, 25, ErrorLastRowPrev ' - DRY (#4)

ErrorLastRowPrev = HandleErrors(ErrorLastRowPrev, wsErr, wsLot, "Zone Field not valid")  ' - DRY (#4)

'Discipline Errors
EvaluateField wsLot, wsReg, wsErr, 26, ErrorLastRowPrev ' - DRY (#4)

ErrorLastRowPrev = HandleErrors(ErrorLastRowPrev, wsErr, wsLot, "Discipline not valid")  ' - DRY (#4)

'Errores de Ex cert
EvaluateField wsLot, wsReg, wsErr, 27, ErrorLastRowPrev ' - DRY (#4)

ErrorLastRowPrev = HandleErrors(ErrorLastRowPrev, wsErr, wsLot, "Ex protection type not valid")  ' - DRY (#4)

'Risk Level Errors
EvaluateField wsLot, wsReg, wsErr, 28, ErrorLastRowPrev ' - DRY (#4)

ErrorLastRowPrev = HandleErrors(ErrorLastRowPrev, wsErr, wsLot, "Risk level not valid")  ' - DRY (#4)

wsLot.Cells(5, "B").value = ErrorLastRowPrev - IMPORTANT_OFFSET

'End

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
WSActual.Activate

End Sub

Sub PutSomeOrder(LastRow2 As Long)

Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("REGISTER")

    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("C7"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("H7"), Order:=xlAscending
        .SortFields.Add Key:=ws.Range("T7"), Order:=xlAscending
        .SetRange ws.Range("A7:AH" & LastRow2)
        .Apply
    End With

End Sub
'EvaluateField needs a better name
Private Sub EvaluateField(wsLot As Worksheet, wsReg As Worksheet, wsErr As Worksheet, field As Long, ErrorLastRow As Long)
On Error Resume Next
    With wsReg.Range("A7:AD" & RegisterNoError)
        .AutoFilter field:=field, Criteria1:="FAIL"
        .SpecialCells(xlCellTypeVisible).Cells.Copy
        wsErr.Rows(ErrorLastRow + 1).PasteSpecial
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With
On Error GoTo 0

ClearAnyExistingFilters wsReg ' - DRY (#4)

End Sub

Private Sub ClearAnyExistingFilters(wsReg As Worksheet)
  On Error Resume Next
    wsReg.ShowAllData
  On Error GoTo 0
End Sub

'MeetsSuccessCriteriaX functions need a more meaningful name

Private Function MeetsSuccessCriteria1(value As Variant) As Boolean
 MeetsSuccessCriteria1 = "Z0" Or value = "Z1" Or value = "Z2"
End Function

Private Function MeetsSuccessCriteria2(value As Variant) As Boolean
 MeetsSuccessCriteria2 = value = "Instrument" Or value = "Electrical"
End Function

Private Function MeetsSuccessCriteria3(value As Variant) As Boolean
 MeetsSuccessCriteria3 = value = "Ex d" Or value = "Ex e" Or value = "Ex n" Or value = "Ex p" Or value = "Ex i"
End Function

Private Function MeetsSuccessCriteria4(value As Variant) As Boolean
 MeetsSuccessCriteria4 = value = "High" Or value = "Medium" Or value = "Low"
End Function

Private Sub LoadOKFail(ByVal isOK As Boolean, ByRef wsReg As Worksheet, ByVal columnID As String, ByVal rowIndex As Integer)
If isOK Then
    wsReg.Range(columnID & rowIndex).value = "OK"
Else
    wsReg.Range(columnID & rowIndex).value = "FAIL"
End If

End Sub
Private Function HandleErrors(ByVal errLastRowPrev As Long, ByRef wsErr As Worksheet, ByRef wsLot As Worksheet, ByVal message As String) As Long
'Recalculate ErrorLastRow
Dim errLastRow As Long
errLastRow = wsErr.Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row

    Dim thisCatErrs As Long
    HandleErrors = errLastRow
    If errLastRow < errLastRowPrev + 1 Then
        'No Errors
        errLastRow = errLastRowPrev
        thisCatErrs = errLastRow - errLastRowPrev
    Else
        'Errors
        thisCatErrs = errLastRow - errLastRowPrev
        wsErr.Range("W" & (errLastRowPrev + 1) & ":W" & errLastRow).value = message
        RegisterNoError = RegisterNoError - (thisCatErrs)
        HandleErrors = errLastRow
    End If

End Function

'Stubs
Public Sub ExportErrorsAndRegistersToProjectFolder()
End Sub

Public Sub PageVisibility(value As Long)
End Sub

Public Sub CreateProjects()
End Sub
\$\endgroup\$
6
  • \$\begingroup\$ Excellent post. I'm pretty sure that you prepared most of it as a generic snippet. Genius,! it so much better than my reviews. \$\endgroup\$
    – TinMan
    Jul 26 '20 at 14:38
  • 1
    \$\begingroup\$ I have never liked Call until I wrote my ShapeTextFormatter class. Because it uses a builder pattern, numerous functions are called without any values being received. Call gave it a cleaner look. \$\endgroup\$
    – TinMan
    Jul 26 '20 at 14:42
  • 1
    \$\begingroup\$ @TinMan thanks. Actually not a generic snippet...but you're right. It could/should have been done that way. Not passing judgement on using Call, just that it's no longer required and usually the less text to enter, visually parse and maintain, the better. \$\endgroup\$
    – BZngr
    Jul 26 '20 at 14:48
  • \$\begingroup\$ I can just say, WOW, thank you very much for your time and effort. I will have a look on the code you wrote and try to do the same by myself. It's true that my original code is a bit of a mesh as I was adding stuff on the go... Got coding last time at the uni, but I wanted to make auto some inspections we need to perform, so learning vba as I'm writing it. I Will update with later developments. Thanks Again! \$\endgroup\$ Jul 26 '20 at 15:40
  • \$\begingroup\$ @BZngr did Try to follow your advice and did the thing below. Much faster and I hope also much cleaner! Thanks Again \$\endgroup\$ Jul 29 '20 at 12:33
1
\$\begingroup\$

The rewritten code (below) is much easier to follow - nicely done!

Below are some general follow-up comments that you may find useful.

  1. Use a Function when a procedure is required to return a value to the caller. From the code: Sub WsExistsAndDelete(ByVal Name As String, ByVal OptionErase As Long, ByRef Result As Boolean) The procedure is expected to modify the input parameter Result with the outcome. And, Result has no meaning until the procedure is called. So, a Function would be preferred here. (e.g, Private Function WsExistsAndDelete(ByVal Name As String, ByVal OptionErase As Long) As Boolean).

  2. Procedure versus variable/parameter casing: Typically procedures begin with a capital letter. Variables and parameters begin with a lower case letter. This makes it easier to know what an identifier is as you scan through code.

  3. Application Structure: I'm going to assume that this process is launched by a button on a worksheet that is linked to the macro ImportDatabase. This makes the worksheet with the button the user interface (UI) and the macro is the UI's code-behind. Generally, UI code-behind has as little behavior as possible (other than managing UI presentation). Using this analogy, organize the button-click-initiated macros into its own dedicated module (making it your code-behind module). So, Sub ImportDatabase() and Sub Reset_workbook() should be in a module dedicated to handling user interactions. Then organize non-user interaction code into other module(s). This organizes your code into a Presentation tier and an Application tier (Data tier is also common and may be something to consider eventually). This is an important distinction to maintain and manage as your application grows. See comment #6 below for an example.

  4. Assign Public or Private visibility to all procedures. Leaving them unassigned defaults to Public. If a Function or Sub is only called from within the module where it is declared, assign it Private visibility. By doing so, when a procedure needs to be made Public because some other module uses it...there is a built-in reminder to consider making it Public and moving the procedure to a module with commonly used code/utilities.

  5. Single Responsibility Principle (SRP): WsExistsAndDelete is an example of a procedure that has too many responsibilities. By its name, the word 'and' betrays that it does at least two things. Its responsibilities include: a) detecting that a worksheet exists. b) Deleting the sheet (sometimes) and, c) Interacting with the User - with a return value that terminates the import. Consider breaking WsExistsAndDelete this into two procedures. As a bonus, the OptionErase parameter and comment are no longer needed once the procedure is broken into single responsibilities.

     Private Function IsExistingWorksheet(worksheetName As String) As Boolean
        IsExistingWorksheet = False
        Dim wrkSheet As Worksheet
        For Each wrkSheet In Worksheets
            If wrkSheet.Name = worksheetName Then
                IsExistingWorksheet = True
                Exit Function
            End If
        Next wrkSheet
     End Function
    
     Private Sub DeleteWorksheet(worksheetName As String)
        If IsExistingWorksheet(worksheetName) Then
            Worksheets(worksheetName).Delete
        End If
     End Sub
    
  6. The logic flow allows changes to be made (e.g., create files and folders) before all required conditions to import a database have been met. It is preferred, to get all required conditions resolved before executing any code that will create permanent artifacts. Consider organizing the ImportDatabase() macro to have clear Presentation and Application tiers...something like:

     'Presentation tier
     Sub ImportDatabase()
         Dim createNewProject As Boolean
         createNewProject = False
    
     'Validate criteria to proceed
     '1. Project has to exist
     '2. "REGISTER" worksheet does not exist
     '3. Valid file is selected by user
    
     ChDir MainWBPath
    
     If Dir(MainWBPath & ProjectName, vbDirectory) = "" Then
         Call OKCancelButton(createNewProject, "Project " & ProjectName & " Does not exist." & vbNewLine & vbNewLine & "Do You want to Create it?")
         If createNewProject = False Then
             Exit Sub
         End If
     End If
    
     'May want this to be the first validation check
     If IsExistingWorksheet("REGISTER") Then
         Call OKButton("Reset before Import.  Exiting database import")
         Exit Sub
     End If
    
     'Not sure what the user can do here other than click OK...does not appear to have the option of
     'terminating the import.
     Call OKButton("Please, be confirm that the DB to import is stored in the REGISTER tab of the file")
    
     'Opening the File and copy to my workbook
     Dim fileName As Variant
     fileName = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")
     If fileName = False Then
         Call OKButton("File not selected.  Exiting database import")
         Exit Sub
     End If
    
     UnhideAll True
     UnprotectAll True
     ScreenAndAlertsOff True
    
     On Error GoTo ResetFlags
     'Validation requirements met, flags set...call the Application tier to do the work
     Dim errors As Long
     errors = ImportDatabaseImpl(fileName, createNewProject)
    
     OKButtonBig "Ex DataBase Import Completed" & vbNewLine & vbNewLine _
     & "TOTAL EQUIPMENT IN Ex DATABASE :  " & RegisterNumb & vbNewLine _
     & "EQUIPMENT EXCLUDED DUE TO ERROR :  " & errors & vbNewLine _
     & "TOTAL EQUIPMENT IMPORTED :  " & RegisterNoError & vbNewLine & vbNewLine _
     & "The Equipment with errors have been recorded on the ERRROR_LOG. You can continue discarting those elements or correct them in the originalfile and do the Import again." & vbNewLine
    
     ResetFlags:
     UnhideAll False
     UnprotectAll False
     ScreenAndAlertsOff False
     CalculationsOff False
    
     End Sub
    

And in another module (Application tier):

    Public Function ImportDatabaseImpl(fileName As Variant, createNewProject As Boolean) As Long
    ImportDatabaseImpl = 0

    If createNewProject Then
        Call CreateProjectFolders
        Call SaveStep(0)
    End If

    Call ResetWorkBookValues
        
    'Opening the File and copy to my workbook
    Dim RegisterWorkBook As Workbook, Mainworkbook As Workbook
    Set Mainworkbook = ActiveWorkbook
    Dim t#, TimerReg(1 To 10) As Long
    t = Timer
    Set RegisterWorkBook = Workbooks.Open(fileName:=fileName)

    RegisterWorkBook.Sheets("REGISTER").Copy After:=Mainworkbook.Sheets("LOTEVAL")
    RegisterWorkBook.Close SaveChanges:=False

    TimerReg(1) = Timer - t

    CalculationsOff True

    Dim WS_REG As Worksheet
    Set WS_REG = Sheets("REGISTER")
    WS_REG.Unprotect Password:="lukenandmeia"

    'Change the formulas to Values
    With WS_REG
        .Range("B1:B12000").value = .Range("B1:B12000").value
        .Range("V1:V12000").value = .Range("V1:V12000").value
        .Range("Y1:Y12000").value = .Range("Y1:Y12000").value
        .Range("G2").value = .Range("G2").value
        .AutoFilterMode = False
    End With

    TimerReg(2) = Timer - t

    'RemoveConditional Formating
    Dim RegFirstCell As Range, RegLastCell As Range, RegisterData As Range
    Set RegFirstCell = WS_REG.Range("A6")
    Set RegLastCell = GetLastCell(WS_REG.Range("A1:AH12000"))
    Set RegisterData = WS_REG.Range(RegFirstCell.Address & ":" & RegLastCell.Address)

    With WS_REG.Cells
        .FormatConditions.Delete
        .Validation.Delete
        .Hyperlinks.Delete
    End With

    Dim RegisterTemp As Long
    RegisterTemp = RegLastCell.Row - Register_Offset
    RegisterNumb = RegisterTemp
    RegisterNoError = RegisterTemp

    TimerReg(3) = Timer - t

    CalculationsOff False

    'Error Filtering
    RemoveErrors RegisterData
    'Reorder
    OrderRegisters WS_REG, "C7", "H7", "T7", 7

    AssignAreasAndLots 'Area Asignation and calculation of Registers and last Rows

    ExportErrorsAndRegisters 'Mirar por si se puede mejorar
        
    ActualStep = 1
    SaveStep 1

    CalculationsOff False

    ImportDatabaseImpl = Sheets("LOTS").Range("B5").value

    End Function
\$\endgroup\$
0
\$\begingroup\$

I spent a bit of time on it and incorporated the suggestions of @BZngr as well as other small tricks. The first code was taking more than two minutes in processing a list of 6000 elements when the one below is taking around 10 seconds to do the same. I can't do much about the delays in the file and copy operations, so I'm quite ok with the result, but, again, any suggestion that makes me improve the way I code would be fantastic.

Option Explicit
Option Base 1


Sub ImportDatabase()


ChDir MainWBPath

UnhideAll True
UnprotectAll True
ScreenAndAlertsOff True

'Maybe Create a sub for this, as can be used by createproject
If Dir(MainWBPath & ProjectName, vbDirectory) = "" Then

    Dim Result As Boolean
    Call OKCancelButton(Result, "Project " & ProjectName & " Does not exist." & vbNewLine & vbNewLine & "Do You want to Create it?")
    If Result = True Then
        Call CreateProjectFolders
        Call SaveStep(0)
    Else
        Call OKButton("You need to create a project before import a DataBase")
        GoTo Endline
    End If

End If

Call ResetWorkBookValues
Call WsExistsAndDelete("REGISTER", 2, Result) 'Option 2 to show a warning, result true means it exist
If Result = True Then GoTo Endline

Call OKButton("Please, be confirm that the DB to import is stored in the REGISTER tab of the file")

'Opening the File and copy to my workbook
Dim FileName As Variant, RegisterWorkBook As Workbook, Mainworkbook As Workbook
FileName = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")
If FileName = False Then GoTo Endline
Set Mainworkbook = ActiveWorkbook
Dim t#, TimerReg(1 To 10) As Long
t = Timer
Set RegisterWorkBook = Workbooks.Open(FileName:=FileName)

RegisterWorkBook.Sheets("REGISTER").Copy After:=Mainworkbook.Sheets("LOTEVAL")
RegisterWorkBook.Close SaveChanges:=False

TimerReg(1) = Timer - t

CalculationsOff True

Dim WS_REG As Worksheet
Set WS_REG = Sheets("REGISTER")
WS_REG.Unprotect Password:="lukenandmeia"

'Change the formulas to Values
With WS_REG
    .Range("B1:B12000").value = .Range("B1:B12000").value
    .Range("V1:V12000").value = .Range("V1:V12000").value
    .Range("Y1:Y12000").value = .Range("Y1:Y12000").value
    .Range("G2").value = .Range("G2").value
    .AutoFilterMode = False
End With

TimerReg(2) = Timer - t

'RemoveConditional Formating
Dim RegFirstCell As Range, RegLastCell As Range, RegisterData As Range
Set RegFirstCell = WS_REG.Range("A6")
Set RegLastCell = GetLastCell(WS_REG.Range("A1:AH12000"))
Set RegisterData = WS_REG.Range(RegFirstCell.Address & ":" & RegLastCell.Address)

With WS_REG.Cells
    .FormatConditions.Delete
    .Validation.Delete
    .Hyperlinks.Delete
End With

Dim RegisterTemp As Long
RegisterTemp = RegLastCell.row - Register_Offset
RegisterNumb = RegisterTemp
RegisterNoError = RegisterTemp

TimerReg(3) = Timer - t

CalculationsOff False

'Error Filtering
RemoveErrors RegisterData
'Reorder
OrderRegisters WS_REG, "C7", "H7", "T7", 7

AssignAreasAndLots 'Area Asignation and calculation of Registers and last Rows

ExportErrorsAndRegisters 'Mirar por si se puede mejorar

Dim Errors As Long
Errors = Sheets("LOTS").Range("B5").value

OKButtonBig "Ex DataBase Import Completed" & vbNewLine & vbNewLine _
& "TOTAL EQUIPMENT IN Ex DATABASE :  " & RegisterNumb & vbNewLine _
& "EQUIPMENT EXCLUDED DUE TO ERROR :  " & Errors & vbNewLine _
& "TOTAL EQUIPMENT IMPORTED :  " & RegisterNoError & vbNewLine & vbNewLine _
& "The Equipment with errors have been recorded on the ERRROR_LOG. You can continue discarting those elements or correct them in the originalfile and do the Import again." & vbNewLine


ActualStep = 1
SaveStep 1

Endline:


UnhideAll False
UnprotectAll False
ScreenAndAlertsOff False
CalculationsOff False


End Sub

Sub CreateProjectFolders()

MkDir MainWBPath & ProjectName
MkDir MainWBPath & ProjectName & "\AREAS"
MkDir MainWBPath & ProjectName & "\LOTS"
MkDir MainWBPath & ProjectName & "\NAV"

End Sub

Sub SaveStep(ByVal Step As Long)
Dim Path As String, Name As String

ScreenAndAlertsOff True

Path = MainWBPath
Name = MainWBname

On Error Resume Next
ActiveWorkbook.SaveAs Path & ProjectName & "\NAV\" & ProjectName & "_Step_" & Step & ".exp", FileFormat:=52
ActiveWorkbook.SaveAs Path & ProjectName & "\" & ProjectName & ".exp", FileFormat:=52
ActiveWorkbook.SaveAs Path & Name, FileFormat:=52
On Error GoTo 0
End Sub

Sub ResetWorkBookValues()

CONTROL.Range("B22").ClearContents
LOTS.Range("B5:D5").ClearContents
LOTS.Range("D9:E100").ClearContents
LOTEVAL.Range("I6:U200").ClearContents

End Sub

Sub WsExistsAndDelete(ByVal Name As String, ByVal OptionErase As Long, ByRef Result As Boolean)

'Option 1 Delete, Option 2 For RegisterCheck
Dim Sheet As Worksheet
UnprotectAll True
Result = False
For Each Sheet In Worksheets
    If Sheet.Name Like Name Then
        Result = True
        If OptionErase = 1 Then Sheet.Delete
        If OptionErase = 2 Then
            Call OKButton("Reset Before Import")
            GoTo Endline
        End If
    Else
        Result = False
    End If
Next Sheet

Endline:
UnprotectAll False

End Sub

Sub RemoveErrors(ByRef RegisterData As Range)

Dim Result As Boolean
Call WsExistsAndDelete("ERROR", 1, Result)
Call CreateWsFromTemplate("ERROR", "ERRORT")

Dim WS_ERROR As Worksheet, WS_REG As Worksheet
Dim i As Integer

Set WS_ERROR = Sheets("ERROR")
Set WS_REG = Sheets("REGISTER")

CalculationsOff True
ClearAllFilters WS_REG

'For the Advance Filter
For i = 1 To 30
WS_REG.Cells(6, i).value = "Column " & i
WS_ERROR.Cells(6, i).value = "Column " & i
Next i

Dim Criteria(1 To 5) As Variant
Dim Column As Variant, Errorcode As Variant

Criteria(1) = Array("=")
Criteria(2) = Array("<>Z1", "<>Z2", "<>Z0")
Criteria(3) = Array("<>Instrument", "<>Electrical")
Criteria(4) = Array("<>Ex d", "<>Ex e", "<>Ex n", "<>Ex p", "<>Ex i")
Criteria(5) = Array("<>High", "<>Medium", "<>Low")
Column = Array("Column 2", "Column 8", "Column 20", "Column 21", "Column 22")
Errorcode = Array("Equipment Id", "Zone", "Discipline", "Protection Type", "Risk")

For i = 1 To 5
Call FilterAndCopy(RegisterData, Column, Criteria, Errorcode, i)
Next i

Dim NumberofErrors As Long, RegisterTemp As Long

NumberofErrors = GetLastCell(WS_ERROR.UsedRange).row - ErrorLog_Offset
LOTS.Range("B5") = NumberofErrors
RegisterTemp = RegisterNoError
RegisterNoError = RegisterNoError - NumberofErrors

WS_REG.Rows(6).ClearContents
WS_ERROR.Rows(6).ClearContents
ClearAllFilters WS_REG


Endline:
CalculationsOff False

End Sub
Sub CreateWsFromTemplate(ByVal Name As String, ByVal Template As String)
Sheets(Template).Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Name
End Sub
Sub ClearAllFilters(WS As Worksheet)
  On Error Resume Next
    WS.ShowAllData
  On Error GoTo 0
End Sub
Sub FilterAndCopy(ByRef RegisterData As Range, ByRef Column As Variant, ByRef Criteria As Variant, ByRef Errorcode As Variant, ByVal Opt As Long)

Dim rngCriteria As Range, ErrLastCell As Range, ErrLastRow As Range
Dim WS_REG As Worksheet, WS_ERROR As Worksheet
Dim i As Long

Set WS_REG = Sheets("REGISTER")
Set WS_ERROR = Sheets("ERROR")
Set rngCriteria = WS_ERROR.Range("AA1:AE2")

Set rngCriteria = rngCriteria.Resize(2, UBound(Criteria(Opt)))
For i = 1 To UBound(Criteria(Opt))
   rngCriteria(1, i) = Column(Opt)
   rngCriteria(2, i) = Criteria(Opt)(i)
Next i

Set ErrLastCell = GetLastCell(WS_ERROR.UsedRange)
Set ErrLastRow = ErrLastCell.EntireRow

        With RegisterData
            .AdvancedFilter xlFilterInPlace, rngCriteria
            .SpecialCells(xlCellTypeVisible).Cells.Copy
            ErrLastRow.Offset(1, 0).PasteSpecial
            ErrLastRow.Offset(1, 0).EntireRow.Delete
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With

Set ErrLastCell = GetLastCell(WS_ERROR.UsedRange)

If (ErrLastCell.row - ErrLastRow.row) <> 0 Then WS_ERROR.Range("W" & ErrLastRow.row + 1 & ":W" & ErrLastCell.row).value = Errorcode(Opt) & " Not Valid"
rngCriteria.Clear

End Sub

Sub OrderRegisters(ByRef WS As Worksheet, ByVal Col1 As String, ByVal Col2 As String, ByVal Col3 As String, Optional ByVal OffsetO As Long = 0)

    With WS.Sort
        .SortFields.Clear
        .SortFields.Add Key:=WS.Range(Col1), Order:=xlAscending
        .SortFields.Add Key:=WS.Range(Col2), Order:=xlAscending
        .SortFields.Add Key:=WS.Range(Col3), Order:=xlAscending
        .SetRange WS.Range("A" & OffsetO & ":AH" & GetLastCell(WS.UsedRange).row)
        .Apply
    End With


End Sub

Sub AssignAreasAndLots()

CalculationsOff True
ScreenAndAlertsOff True

Dim dictArea As New Scripting.Dictionary, dictAreaCode As New Scripting.Dictionary, dictLots As New Scripting.Dictionary
Dim WS_REG As Worksheet, WS_LOTS As Worksheet, i As Long, k As Long

dictArea.CompareMode = TextCompare

Set WS_REG = Sheets("REGISTER")
Set WS_LOTS = Sheets("LOTS")

For i = 7 To RegisterNoError + Register_Offset

dictArea(WS_REG.Range("C" & i).value) = i
dictAreaCode(Sheets("REF1").Range("A" & i - 6).value) = i
With WS_REG
    For k = 0 To dictArea.Count - 1
        If .Range("C" & i).value = dictArea.Keys(k) Then .Range("AA" & i).value = dictAreaCode.Keys(k)
    Next k
    .Range("AB" & i).value = .Range("H" & i).value
    .Range("AC" & i).value = .Range("V" & i).value
    .Range("AD" & i).value = .Range("AA" & i).value & "_" & .Range("AB" & i).value & "_" & Left(.Range("AC" & i).value, 1)
    dictLots(.Range("AD" & i).value) = .Range("AA" & i).value
End With

Next i

For i = 0 To dictArea.Count - 1
WS_LOTS.Range("E9").value = 7
With WS_LOTS
.Range("A" & 9 + i).value = dictArea.Keys(i)
If .Range("A" & 9 + i).value <> """" Then .Range("C" & 9 + i).value = dictAreaCode.Keys(i)
.Range("E" & 10 + i).value = dictArea.Items(i) + 1
.Range("F" & 9 + i).value = dictArea.Items(i)
.Range("D" & 9 + i).value = .Range("F" & 9 + i) - .Range("E" & 9 + i) + 1
End With
Next i
WS_LOTS.Range("E" & 9 + dictArea.Count).ClearContents
WS_LOTS.Range("A5") = dictArea.Count

For i = 0 To dictLots.Count - 1
WS_LOTS.Range("G" & 9 + i).value = dictLots.Keys(i)
WS_LOTS.Range("Q" & 9 + i).value = dictLots.Keys(i)
LOTEVAL.Range("B" & 6 + i).value = dictLots.Keys(i)
LOTEVAL.Range("C" & 6 + i).value = dictLots.Items(i)
For k = 0 To dictArea.Count - 1
        If LOTEVAL.Range("C" & 6 + i).value = dictAreaCode.Keys(k) Then LOTEVAL.Range("D" & 6 + i).value = dictArea.Keys(k)
Next k
Next i

WS_LOTS.Range("E5") = dictLots.Count

CalculationsOff False

End Sub

Sub Reset_workbook()

ScreenAndAlertsOff True
UnprotectAll True

Dim WS As Worksheet

Dim Result As Boolean
Call OKCancelButton(Result, "This Will Reset All the Fields." & vbNewLine & "Are You Sure?")
If Result <> True Then GoTo Endline

For Each WS In ThisWorkbook.Sheets
    If WS.Name Like "AREA_*" Then
        WS.Delete
    ElseIf WS.Name Like "LOT_*" Then
        WS.Delete
    ElseIf WS.Name Like "REGISTER" Then
        WS.Delete
    End If
Next WS

ResetWorkBookValues
   
ActualStep = 0
   
Endline:

UnprotectAll False
ScreenAndAlertsOff False


End Sub

To complete the above, there are some public declarations and functions from other modules:

Option Explicit

Public Const Register_Offset As Long = 6
Public Const ErrorLog_Offset As Long = 6
Public Const LotsOffset As Long = 12



Public Property Get MainWBPath() As String
MainWBPath = Application.ThisWorkbook.Path & "\"
End Property

Public Property Get MainWBname() As String
MainWBname = ThisWorkbook.Name
End Property

Public Property Get NumberOfAreas() As String
NumberOfAreas = WS_CONTROL.Range("C6").Value2
End Property

Public Property Get NumberOfLots() As String
NumberOfLots = CONTROL.Range("C7").Value2
End Property

Public Property Get ProjectName() As String
ProjectName = Left(CONTROL.Range("C4").value, 8) & "_" & (Format(CONTROL.Range("C5").value, "yyyy_mm_dd"))
End Property
Public Property Get RegisterNoError() As Long
    RegisterNoError = Worksheets("LOTS").Range("C5").value
End Property

Public Property Let RegisterNoError(value As Long)
    Worksheets("LOTS").Range("C5").value = value
End Property

Public Property Get RegisterNumb() As Long
    RegisterNumb = Worksheets("LOTS").Range("D5").value
End Property

Public Property Let RegisterNumb(value As Long)
    Worksheets("LOTS").Range("D5").value = value
End Property
Public Property Get ActualStep() As Long
    ActualStep = Worksheets("CONTROL").Range("O3").value
End Property

Public Property Let ActualStep(value As Long)
    Worksheets("CONTROL").Range("O3").value = value
End Property

Public Function GetLastCell(Optional ByRef rng As Range = Nothing) As Range
'Credit to @ZygD

    'Returns the last cell containing a value, or A1 if Worksheet is empty

    Const NONEMPTY As String = "*"
    Dim lRow As Range, lCol As Range, GetMaxCell As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.Activesheets.UsedRange
    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                        After:=.Cells(1, 1), _
                                        SearchDirection:=xlPrevious, _
                                        SearchOrder:=xlByRows)
            If Not lRow Is Nothing Then
                Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                            After:=.Cells(1, 1), _
                                            SearchDirection:=xlPrevious, _
                                            SearchOrder:=xlByColumns)

                Set GetLastCell = .Parent.Cells(lRow.row, lCol.Column)
            End If
        End With
    End If
End Function

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.