The code has been updated, and I am getting an error, even after checking Microsoft Scripting RunTime off to be active. Below is the error:
Option Explicit
Sub Update_JL()
Dim wsJL As Worksheet 'Jobs List
Dim wsJD As Worksheet 'Jobs Data
Dim wsJAR As Worksheet 'JL Archive
Dim lastrow As Long, fstcell As Long
Dim strCompany As String, strPart As String, strPath As String
Set wsJL = Sheets("Jobs List")
Set wsJD = Sheets("Jobs Data")
Set wsJAR = Sheets("JL Archive")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
With Intersect(wsJL.UsedRange, wsJL.Columns("Q"))
.AutoFilter 1, "<>Same"
With Intersect(.Offset(2).EntireRow, .Parent.Range("B:O"))
.Copy wsJAR.Cells(Rows.Count, "B").End(xlUp).Offset(1)
.EntireRow.Delete
End With
.AutoFilter
End With
With wsJD
'Clean empty cells in Column C
lastrow = Range("B" & Rows.Count).End(xlUp).Row + 1
Range("C5:C" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
With Intersect(wsJD.UsedRange, wsJD.Columns("Q"))
ActiveSheet.Range("P:Q").Calculate
.AutoFilter 1, "<>Different"
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
With wsJD
.AutoFilterMode = False
Intersect(.UsedRange, .Columns("G")).Cut .Range("F1")
Intersect(.UsedRange, .Columns("H")).Cut .Range("G1")
Intersect(.UsedRange, .Columns("L")).Cut .Range("H1")
Intersect(.UsedRange, .Columns("N")).Cut .Range("I1")
Intersect(.UsedRange, .Range("B:I")).Copy wsJL.Cells(Rows.Count, "B").End(xlUp).Offset(1)
End With
With wsJL
lastrow = wsJL.Cells(Rows.Count, "B").End(xlUp).Row
wsJL.Range("R1:Y1").Copy
wsJL.Range("B3:I" & lastrow).PasteSpecial xlPasteFormats
lastrow = wsJL.Cells(Rows.Count, "J").End(xlUp).Row + 1
fstcell = wsJL.Cells(Rows.Count, "I").End(xlUp).Row
wsJL.Range("Z1:AG1").Copy wsJL.Range("J" & fstcell & ":Q" & lastrow)
wsJL.Range("S2:X2").Copy wsJL.Range("P" & fstcell & ":T" & lastrow)
lastrow = wsJL.Cells(Rows.Count, "B").End(xlUp).Row
wsJL.Range("J:Q").Calculate
Range("B3:N" & lastrow).Sort key1:=Range("F3" & lastrow), order1:=xlAscending
End With
With wsJAR
lastrow = wsJAR.Cells(Rows.Count, "O").End(xlUp).Row
wsJAR.Range("R2:T2").Copy wsJAR.Range("R3:T" & lastrow)
wsJAR.Range("M1").Copy wsJAR.Range("M3:M" & lastrow)
End With
With wsJL
strCompany = Range("C3") ' assumes company name in C3
strPart = CleanName(Range("D3")) ' assumes part in D1
strPath = CleanName(Range("Lists!$G$2"))
If Not FolderExists(strPath & strCompany) Then
'company doesn't exist, so create full path
FolderCreate strPath & strCompany & Application.PathSeparator & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strCompany & Application.PathSeparator & strPart) Then
FolderCreate strPath & strCompany & Application.PathSeparator & strPart
End If
End If
Range("J:M").Calculate
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim fso As New FileSystemObject
If Functions.FolderExists(path) Then
Exit Function
Else
On Error GoTo DeadInTheWater
fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
Exit Function
End If
DeadInTheWater:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim fso As New FileSystemObject
If fso.FolderExists(path) Then FolderExists = True
End Function
Function CleanName(strName As String) As String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters
CleanName = Replace(strName, "/", "")
CleanName = Replace(CleanName, "*", "")
CleanName = Replace(CleanName, ".", "")
End Function
The error is here so far, for this is as far as the script has allowed me to go. The error is:
Compile Error: Variable not defined
The code is below, the place of contention is here between the *. If **Functions**.FolderExists(path) Then
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim fso As New FileSystemObject
If Functions.FolderExists(path) Then
Exit Function
Else
On Error GoTo DeadInTheWater
fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
Exit Function
End If
DeadInTheWater:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
You just had the code a little off.
each new function should go below the sub, as it is a separate procedure that gets called from the sub. Worth reading up on functions and sub and calling them from one another.
I’ve reorganized below. Hopefully, will be a little more clear and clean.