【发布时间】：2012-06-01 13:54:35
【问题描述】：
代码已更新，我收到错误消息，即使在检查 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
【问题讨论】：
-
为什么需要一个子？将内容分成多个部分有助于提高可读性。如果 subs 或函数需要一个接一个地调用，那么设置一个 main 例程来调用它们
-
原因是因为这需要一个按钮推送的概念。这就是为什么。我无法调整它以使其成为多按钮选项。
-
您不需要多个按钮。 Sean 的建议是创建一个除了调用其他子程序之外什么都不做的主程序。您的按钮将调用主程序。
-
以这个答案中的代码为例：stackoverflow.com/a/10779424/138938 DispatchTotalsByPNNumber 是一个调用其他的子。
-
这并不是说不同。我修复了 OP 对我在下面的答案中构建的函数的原始集成，他误解了如何集成我所做的函数调用。