コードが更新され、Microsoft Scripting RunTimeがアクティブであることを確認した後でも、エラーが発生します。以下はエラーです：
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
これまでのところ、エラーはここにあります。これは、スクリプトで許可されている限りです。エラーは次のとおりです。
Compile Error: Variable not defined
コードは以下のとおりです。競合の場所はここにあり*ます。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