Excel Data Import and Manipulation

Question 1

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

Question 2

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

(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.
(Deprecated) Call is no longer required to call procedures. It can be removed.
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).
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.
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.
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.

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.
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

Question 3

Excellent post. I'm pretty sure that you prepared most of it as a generic snippet. Genius,! it so much better than my reviews.

Question 4

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.

Question 5

@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.

Question 6

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!

Question 7

@BZngr did Try to follow your advice and did the thing below. Much faster and I hope also much cleaner! Thanks Again

Question 8

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

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

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).
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.
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.
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.
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
```

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

Question 9

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

BZngr BZngr 1,2377 silver badges9 bronze badges · Accepted Answer · 2020-07-26 12:36:53Z

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

(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.
(Deprecated) Call is no longer required to call procedures. It can be removed.
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).
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.
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.
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.

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.
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

Excellent post. I'm pretty sure that you prepared most of it as a generic snippet. Genius,! it so much better than my reviews.
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.
@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.
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!
@BZngr did Try to follow your advice and did the thing below. Much faster and I hope also much cleaner! Thanks Again

Stack Exchange Network

Excel Data Import and Manipulation

3 Answers 3

Your Answer

Sign up or log in

Post as a guest

Post as a guest

Linked

Hot Network Questions

Excel Data Import and Manipulation

3 Answers 3

Your Answer

Sign up or log in

Post as a guest

Post as a guest

Linked

Related

Hot Network Questions