我目前正在开发一种管理工具，旨在供整个办公室在日常管理中使用。这个基于excel的工具是一个多工作表工作簿，可以自动执行某些操作（使用 Private Sub Worksheet_Change ）或通过特定按钮进行操作。
特别地，目的之一是在我输入活动描述后自动创建正在运行的项目（参数）的验证列表，该列表保存在另一张表中。即使代码看起来运行顺利，每次我保存并关闭工作表时也会弹出以下错误： Excel error。 这似乎与我在另一张工作表（“日历”）中遇到的另一个问题类似，在该工作表中，代码必须再次执行类似的任务，以更改插入项目的单元格旁边的单元格的验证。
基本上，问题似乎主要是由此参数验证列表引起的，但我无法确切找到位置。你可以支持吗？
在此您可以找到两张纸的代码：
Private Sub Worksheet_Change(ByVal Target As Range)
'On Error GoTo exitsub
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim ws_proj_port As Worksheet
Dim ws_act_cat As Worksheet
Dim ws_curr_week As Worksheet
Dim ws_cal As Worksheet
Dim ws_graph As Chart
Dim proj_type As String
Dim act_proj_arr(100) As String
Dim act_proj_val As String
Dim lastrow_act As Integer
Dim hrs_done As Double
Dim hrs_day As Double
Dim hrs_week As Double
Dim hrs_marker As Double
Dim i As Integer
Dim j As Integer
Dim r As Integer
Set ws_curr_week = ActiveSheet
Set ws_proj_port = Sheets("Projects portfolio")
Set ws_act_cat = Sheets("Activity categories")
Set ws_cal = Sheets("Calendar")
proj_type = ""
proj_color = ""
proj_name = ""
act_cat = ""
act_cat_j = ""
proj_imp = ""
If Target.row > 2 And Target.row < 34 And Target.Column < 16 Then
If Target.Column = 1 Then
If Target.Value <> "" Then
ws_curr_week.Cells(Target.row, Target.Column + 1).Value = "- to be selected -"
'------- START project validation list creation
ws_curr_week.Activate
ws_curr_week.Cells(Target.row, Target.Column + 1).Validation.Delete
ws_curr_week.Cells(Target.row, Target.Column + 1).Select
With Selection.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=week_proj"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'----- END project validation list creation
Else
ws_curr_week.Cells(Target.row, Target.Column + 1).ClearContents
ws_curr_week.Cells(Target.row, Target.Column + 1).Validation.Delete
ws_curr_week.Cells(Target.row, Target.Column + 2).ClearContents
ws_curr_week.Cells(Target.row, Target.Column + 2).Validation.Delete
ws_curr_week.Cells(Target.row, 7).ClearContents
End If
ElseIf Target.Column = 2 Then
If Target.Value <> "" Then
'------- START activity validation list creation
ws_proj_port.Activate
ws_proj_port.Range("A2").Select
Selection.End(xlDown).Select
r = ActiveCell.row
proj_matrix = "A2:H" & r
proj_name = ws_curr_week.Cells(Target.row, Target.Column).Value
proj_type = Application.VLookup(proj_name, ws_proj_port.Range(proj_matrix), 2, False)
proj_color = Application.VLookup(proj_name, ws_proj_port.Range(proj_matrix), 3, False)
ws_act_cat.Activate
ws_act_cat.Range("D2").Select
Selection.End(xlDown).Select
lastrow_act = ActiveCell.row
j = 0
i = 2
If proj_type = "Linework" Then
For i = 2 To lastrow_act
If ws_act_cat.Cells(i, 1).Value = proj_type And ws_act_cat.Cells(i, 2).Value = proj_name Then
act_proj_arr(j) = ws_act_cat.Cells(i, 4).Value
j = j + 1
End If
Next i
Else
For i = 2 To lastrow_act
If ws_act_cat.Cells(i, 1).Value = proj_type Then
act_proj_arr(j) = ws_act_cat.Cells(i, 4).Value
j = j + 1
End If
Next i
End If
act_proj_val = Join(act_proj_arr, ",")
ws_curr_week.Activate
ws_curr_week.Cells(Target.row, Target.Column + 1).Value = "- to be selected -"
ws_curr_week.Cells(Target.row, Target.Column + 1).Validation.Delete
ws_curr_week.Cells(Target.row, Target.Column + 1).Select
With Selection.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=act_proj_val
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'------- END activity validation list creation
'Set Importance Y/N
ws_curr_week.Cells(Target.row, 7).Value = Application.VLookup(proj_name, ws_proj_port.Range(proj_matrix), 7, False)
Else
ws_curr_week.Cells(Target.row, 7).ClearContents
ws_curr_week.Cells(Target.row, Target.Column + 1).ClearContents
ws_curr_week.Cells(Target.row, Target.Column + 1).Validation.Delete
End If
ElseIf Target.Column = 10 Or Target.Column = 11 Then
If Target.Value <> "" Then
ws_curr_week.Cells(Target.row, 12).Value = Format(Date, "dd/mm", vbMonday, vbFirstJan1)
ws_curr_week.Cells(Target.row, 13).Value = Application.Text(Date, "[$-809]dddd")
Else
ws_curr_week.Cells(Target.row, 12).ClearContents
ws_curr_week.Cells(Target.row, 13).ClearContents
End If
calc_hrs hrs_done, hrs_day, hrs_week, hrs_marker
create_graph hrs_done, hrs_day, hrs_week, hrs_marker
ElseIf Target.Column = 4 And ws_curr_week.Range("P2") <> "Sunday" And ws_curr_week.Range("P2") <> "Saturday" And ws_curr_week.Range("P2") <> "Monday" Then
calc_hrs hrs_done, hrs_day, hrs_week, hrs_marker
create_graph hrs_done, hrs_day, hrs_week, hrs_marker
End If
End If
Target.Cells.Select
exitsub:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'On Error GoTo exitsub
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim ws_proj_port As Worksheet
Dim ws_act_cat As Worksheet
Dim ws_cal As Worksheet
Dim ws_hid As Worksheet
Dim act_proj_arr(100) As String
Dim act_proj_val As String
Dim proj_name As String
Dim last_proj As Integer
Set ws_proj_port = Sheets("Projects portfolio")
Set ws_act_cat = Sheets("Activity categories")
Set ws_cal = Sheets("Calendar")
Set ws_hid = Sheets("Hidden")
If Target.Column > 2 And Target.Column < 14 And Target.row < 16 Then
If Target.Column Mod 2 <> 0 Then
If Target.Value = "-" Then
ws_cal.Cells(Target.row, Target.Column + 1).Value = "-"
ws_cal.Range(Cells(Target.row, Target.Column), Cells(Target.row, Target.Column + 1)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
ws_cal.Cells(Target.row, Target.Column).Select
ElseIf Target.Value = "Lunch" Then
ws_cal.Cells(Target.row, Target.Column + 1).ClearContents
ws_cal.Range(Cells(Target.row, Target.Column), Cells(Target.row, Target.Column + 1)).Select
With Selection
.Style = "Accent2"
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
ElseIf Target.Value <> "" Then
'------- START formatting
proj_name = ws_cal.Cells(Target.row, Target.Column).Value
ws_proj_port.Activate
ws_proj_port.Range("A2").Select
Selection.End(xlDown).Select
last_proj = ActiveCell.row
proj_arr = ws_proj_port.Range("A1:A" & last_proj)
proj_row = Application.Match(proj_name, proj_arr, 0)
ws_proj_port.Activate
ws_proj_port.Range("H" & proj_row).Select
Selection.Copy
ws_cal.Activate
ws_cal.Range(Cells(Target.row, Target.Column), Cells(Target.row, Target.Column + 1)).PasteSpecial xlPasteFormats
ws_cal.Range(Cells(Target.row, Target.Column), Cells(Target.row, Target.Column + 1)).Interior.Color = ws_proj_port.Range("H" & proj_row).Interior.Color
ws_cal.Range(Cells(Target.row, Target.Column), Cells(Target.row, Target.Column + 1)).WrapText = True
Application.CutCopyMode = False
'------- END formatting
'------- START activity validation list creation
ws_proj_port.Activate
ws_proj_port.Range("A2").Select
Selection.End(xlDown).Select
r = ActiveCell.row
proj_matrix = "A2:H" & r
proj_name = ws_cal.Cells(Target.row, Target.Column).Value
proj_type = Application.VLookup(proj_name, ws_proj_port.Range(proj_matrix), 2, False)
proj_color = Application.VLookup(proj_name, ws_proj_port.Range(proj_matrix), 3, False)
ws_act_cat.Activate
ws_act_cat.Range("D2").Select
Selection.End(xlDown).Select
lastrow_act = ActiveCell.row
j = 0
i = 2
If proj_type = "Linework" Then
For i = 2 To lastrow_act
If ws_act_cat.Cells(i, 1).Value = proj_type And ws_act_cat.Cells(i, 2).Value = proj_name Then
act_proj_arr(j) = ws_act_cat.Cells(i, 4).Value
j = j + 1
Else
End If
Next i
Else
For i = 2 To lastrow_act
If ws_act_cat.Cells(i, 1).Value = proj_type Then
act_proj_arr(j) = ws_act_cat.Cells(i, 4).Value
j = j + 1
Else
End If
Next i
End If
act_proj_val = Join(act_proj_arr, ",")
ws_cal.Activate
ws_cal.Cells(Target.row, Target.Column + 1).Value = "- to be selected -"
ws_cal.Cells(Target.row, Target.Column + 1).Validation.Delete
ws_cal.Cells(Target.row, Target.Column + 1).Select
With Selection.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=act_proj_val
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'------- END activity validation list creation
Else
ws_cal.Cells(Target.row, Target.Column).Select
Call cell_cal_format
ws_cal.Cells(Target.row, Target.Column + 1).ClearContents
ws_cal.Cells(Target.row, Target.Column + 1).Validation.Delete
ws_cal.Cells(Target.row, Target.Column + 1).Select
Call cell_cal_format
ws_cal.Cells(Target.row, Target.Column).Select
End If
End If
End If
exitsub:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub cell_cal_format()
Selection.Style = "Normal"
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
谢谢！
Alessio